From: Félix Sipma Date: Mon, 4 Feb 2019 10:06:20 +0000 (+0000) Subject: Import patat_0.8.2.1.orig.tar.gz X-Git-Tag: archive/raspbian/0.8.2.1-1+rpi1^2~2 X-Git-Url: https://dgit.raspbian.org/%22http://www.example.com/cgi/%22/%22http:/www.example.com/cgi/%22?a=commitdiff_plain;h=bc1d31df4040579a4cccae9bd51dc67bf08951db;p=patat.git Import patat_0.8.2.1.orig.tar.gz [dgit import orig patat_0.8.2.1.orig.tar.gz] --- bc1d31df4040579a4cccae9bd51dc67bf08951db diff --git a/.circleci/config.yml b/.circleci/config.yml new file mode 100644 index 0000000..4d7780d --- /dev/null +++ b/.circleci/config.yml @@ -0,0 +1,37 @@ +version: 2 + +workflows: + version: 2 + build-workflow: + jobs: + - build: + filters: + tags: + only: /.*/ + +jobs: + build: + # This image has most Haskell stuff preinstalled. + docker: + - image: 'fpco/stack-build:latest' + + steps: + - checkout + - restore_cache: + key: 'v4-patat-{{ arch }}-{{ .Branch }}' + - run: + # We set jobs to 1 here because that prevents Out-Of-Memory exceptions + # while compiling dependencies. + name: 'Install' + command: '.circleci/tickle.sh stack build --pedantic --copy-bins --jobs=1 --no-terminal' + - run: + name: 'Run tests' + command: 'make test' + - save_cache: + key: 'v4-patat-{{ arch }}-{{ .Branch }}-{{ .Revision }}' + paths: + - '~/.stack-work' + - '~/.stack' + - run: + name: 'Upload release' + command: '.circleci/release.sh "$CIRCLE_TAG"' diff --git a/.circleci/release.sh b/.circleci/release.sh new file mode 100755 index 0000000..b5f7f76 --- /dev/null +++ b/.circleci/release.sh @@ -0,0 +1,46 @@ +#!/bin/bash +set -o nounset -o errexit -o pipefail + +TAG="$1" +SUFFIX="linux-$(uname -m)" +USER="jaspervdj" +REPOSITORY="$(basename -- *.cabal ".cabal")" +BINARY="$REPOSITORY" + +echo "Tag: $TAG" +echo "Suffix: $SUFFIX" +echo "Repository: $REPOSITORY" + +$BINARY --version + +if [[ -z "$TAG" ]]; then + echo "Not a tagged build, skipping release..." + exit 0 +fi + +# Install ghr +GHR_VERSION="v0.5.4" +wget --quiet \ + "https://github.com/tcnksm/ghr/releases/download/${GHR_VERSION}/ghr_${GHR_VERSION}_linux_386.zip" +unzip ghr_${GHR_VERSION}_linux_386.zip + +# Install upx +UPX_VERSION="3.94" +wget --quiet \ + "https://github.com/upx/upx/releases/download/v${UPX_VERSION}/upx-${UPX_VERSION}-amd64_linux.tar.xz" +tar xf upx-${UPX_VERSION}-amd64_linux.tar.xz +mv upx-${UPX_VERSION}-amd64_linux/upx . + +# Create tarball +PACKAGE="$REPOSITORY-$TAG-$SUFFIX" +mkdir -p "$PACKAGE" +cp "$(which "$BINARY")" "$PACKAGE" +./upx -q "$PACKAGE/$BINARY" +cp README.* "$PACKAGE" +cp CHANGELOG.* "$PACKAGE" +cp extra/patat.1 "$PACKAGE" +tar -czf "$PACKAGE.tar.gz" "$PACKAGE" +rm -r "$PACKAGE" + +# Actually upload +./ghr -u "$USER" -r "$REPOSITORY" "$TAG" "$PACKAGE.tar.gz" diff --git a/.circleci/tickle.sh b/.circleci/tickle.sh new file mode 100755 index 0000000..195c29c --- /dev/null +++ b/.circleci/tickle.sh @@ -0,0 +1,24 @@ +#!/bin/bash +set -o nounset -o errexit -o pipefail + +function tickle() { + while [ true ]; do + echo "[$(date +%H:%M:%S)] Tickling..." + sleep 60 + done +} + +echo "Forking tickle process..." +tickle & +TICKLE_PID=$! + +echo "Forking build process..." +eval $@ & +BUILD_PID=$! + +echo "Waiting for build thread ($BUILD_PID)..." +wait $BUILD_PID + +echo "Killing tickle thread ($TICKLE_PID)..." +kill $TICKLE_PID +echo "All done!" diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..da4d999 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +*.o +*.hi +extra/make-man +extra/patat.1 +.stack-work +dist +tags diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..b3b72e9 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,157 @@ +# Changelog + +- 0.8.2.1 (2019-02-03) + * Bump `pandoc` to 2.6 + * Bump `ansi-terminal` to 0.10 + +- 0.8.2.0 (2019-01-24) + * GHC 7.8 compatibility + +- 0.8.1.3 (2019-01-24) + * Bump `pandoc` to 2.4 + * Bump `yaml` to 0.11 + +- 0.8.1.2 (2018-10-29) + * Work around test failure caused by slightly different syntax highlighting + in different pandoc versions + +- 0.8.1.1 (2018-10-26) + * Tickle CircleCI cache + +- 0.8.1.0 (2018-10-26) + * Add support for italic ansi code in themes + * Fix centered titles not being centered (contribution by Hamza Haiken) + +- 0.8.0.0 (2018-08-31) + * Themed border rendering improvements (contribution by Hamza Haiken) + * Add support for margins (contribution by Hamza Haiken) + * Add RGB colour support for themes (contribution by Hamza Haiken) + * Add experimental images support + * Add images support for iTerm2 (contribution by @2mol) + +- 0.7.2.0 (2018-05-08) + * GHC 8.4 compatibility + +- 0.7.1.0 (2018-05-08) + * GHC 8.4 compatibility + +- 0.7.0.0 (2018-05-04) + * Support HTML-style comments + +- 0.6.1.2 (2018-04-30) + * Bump `pandoc` to 2.2 + +- 0.6.1.1 (2018-04-27) + * Bump `aeson` to 1.3 + * Bump `skylighting` to 0.7 + * Bump `time` to 1.9 + * Bump `ansi-terminal` to 0.8 + +- 0.6.1.0 (2018-01-28) + * Bump `skylighting` to 0.6 + * Bump `pandoc` to 2.1 + * Bump `ansi-terminal` to 0.7 + +- 0.6.0.1 (2017-12-24) + * Automatically upload linux binary to GitHub + +- 0.6.0.0 (2017-12-19) + * Make pandoc extensions customizable in the configuration + * Bump `pandoc` to 2.0 + +- 0.5.2.2 (2017-06-14) + * Add `network-uri` dependency to fix travis build + +- 0.5.2.1 (2017-06-14) + * Bump `optparse-applicative-0.14` dependency + +- 0.5.2.0 (2017-05-16) + * Add navigation using `PageUp` and `PageDown`. + * Use `skylighting` instead of deprecated `highlighting-kate` for syntax + highlighting. + +- 0.5.1.2 (2017-04-26) + * Make build reproducible even if timezone changes (patch by Félix Sipma) + +- 0.5.1.1 (2017-04-23) + * Include `README` in `Extra-source-files` so it gets displayed on Hackage + +- 0.5.1.0 (2017-04-23) + * Bump `aeson-1.2` dependency + * Fix vertical alignment of title slides + * Fix wrapping issue with inline code at end of line + * Add bash-completion script generation to Makefile + +- 0.5.0.0 (2017-02-06) + * Add a `slideLevel` option & autodetect it. This changes the way `patat` + splits slides. For more information, see the `README` or the `man` page. + If you just want to get the old behavior back, just add: + + --- + patat: + slideLevel: 1 + ... + + To the top of your presentation. + + * Clear the screen when finished with the presentation. + +- 0.4.7.1 (2017-01-22) + * Bump `directory-1.3` dependency + * Bump `time-1.7` dependency + +- 0.4.7.0 (2017-01-20) + * Bump `aeson-1.1` dependency + * Parse YAML for settings using `yaml` instead of pandoc + * Clarify watch & autoAdvance combination in documentation. + +- 0.4.6.0 (2016-12-28) + * Redraw the screen on unknown commands to prevent accidental typing from + showing up. + * Make the cursor invisible during the presentation. + * Move the footer down one more line to gain some screen real estate. + +- 0.4.5.0 (2016-12-05) + * Render the date in a locale-independent manner (patch by Daniel + Shahaf). + +- 0.4.4.0 (2016-12-03) + * Force the use of UTF-8 when generating the man page. + +- 0.4.3.0 (2016-12-02) + * Use `SOURCE_DATE_EPOCH` if it is present instead of getting the date from + `git log`. + +- 0.4.2.0 (2016-12-01) + * Fix issues with man page generation on Travis. + +- 0.4.1.0 (2016-12-01) + * Fix compatibility with `pandoc-1.18` and `pandoc-1.19`. + * Add a man page. + +- 0.4.0.0 (2016-11-15) + * Add configurable auto advancing. + * Support fragmented slides. + +- 0.3.3.0 (2016-10-31) + * Add a `--version` flag. + * Add support for `pandoc-1.18` which includes a new `LineBlock` element. + +- 0.3.2.0 (2016-10-20) + * Keep running even if errors are encountered during reload. + +- 0.3.1.0 (2016-10-18) + * Fix compilation with `lts-6.22`. + +- 0.3.0.0 (2016-10-17) + * Add syntax highlighting support. + * Fixed slide clipping after reload. + +- 0.2.0.0 (2016-10-13) + * Add theming support. + * Fix links display. + * Add support for wrapping. + * Allow org mode as input format. + +- 0.1.0.0 (2016-10-02) + * Upload first version from hotel wifi in Kalaw. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1f53f40 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d8513a5 --- /dev/null +++ b/Makefile @@ -0,0 +1,26 @@ +# We use `?=` to set SOURCE_DATE_EPOCH only if it is not present. Unfortunately +# we can't use `git --date=unix` since only very recent git versions support +# that, so we need to make a round trip through `date`. +SOURCE_DATE_EPOCH?=$(shell date '+%s' \ + --date="$(shell git log -1 --format=%cd --date=rfc)") + +extra/patat.1: README.md + SOURCE_DATE_EPOCH="$(SOURCE_DATE_EPOCH)" patat-make-man >$@ + +extra/patat.bash-completion: + patat --bash-completion-script patat >$@ + +completion: extra/patat.bash-completion + +man: extra/patat.1 + +# Also check if we can generate the manual. +test: man + bash test.sh + +clean: + rm -f extra/patat.1 + rm -f extra/make-man + rm -f extra/patat.bash-completion + +.PHONY: man completion test clean diff --git a/README.md b/README.md new file mode 100644 index 0000000..e0ae34c --- /dev/null +++ b/README.md @@ -0,0 +1,584 @@ +patat +===== + +[![Build Status](https://img.shields.io/circleci/project/github/jaspervdj/patat.svg)](https://circleci.com/gh/jaspervdj/patat) [![Hackage](https://img.shields.io/hackage/v/patat.svg)](https://hackage.haskell.org/package/patat) [![GitHub tag](https://img.shields.io/github/tag/jaspervdj/patat.svg)]() + +`patat` (**P**resentations **A**top **T**he **A**NSI **T**erminal) is a small +tool that allows you to show presentations using only an ANSI terminal. It does +not require `ncurses`. + +Features: + +- Leverages the great [Pandoc] library to support many input formats including + [Literate Haskell]. +- Supports [smart slide splitting](#input-format). +- Slides can be split up into [multiple fragments](#fragmented-slides) +- There is a [live reload](#running) mode. +- [Theming](#theming) support including 24-bit RGB. +- [Auto advancing](#auto-advancing) with configurable delay. +- Optionally [re-wrapping](#line-wrapping) text to terminal width with proper + indentation. +- Syntax highlighting for nearly one hundred languages generated from [Kate] + syntax files. +- Experimental [images](#images) support. +- Written in [Haskell]. + +![screenshot](extra/screenshot.png?raw=true) + +[Kate]: https://kate-editor.org/ +[Haskell]: http://haskell.org/ +[Pandoc]: http://pandoc.org/ + +Table of Contents +----------------- + +- [Table of Contents](#table-of-contents) +- [Installation](#installation) + - [Pre-built-packages](#pre-built-packages) + - [From source](#from-source) +- [Running](#running) +- [Options](#options) +- [Controls](#controls) +- [Input format](#input-format) +- [Configuration](#configuration) + - [Line wrapping](#line-wrapping) + - [Auto advancing](#auto-advancing) + - [Advanced slide splitting](#advanced-slide-splitting) + - [Fragmented slides](#fragmented-slides) + - [Theming](#theming) + - [Syntax Highlighting](#syntax-highlighting) + - [Pandoc Extensions](#pandoc-extensions) + - [Images](#images) +- [Trivia](#trivia) + +Installation +------------ + +### Pre-built-packages + +- Archlinux: +- Debian: +- Ubuntu: +- openSUSE: + +You can also find generic linux binaries here: +. + +### From source + +Installation from source is very easy. You can build from source using `stack +install` or `cabal install`. `patat` is also available from [Hackage]. + +[Hackage]: https://hackage.haskell.org/package/patat + +For people unfamiliar with the Haskell ecosystem, this means you can do either +of the following: + +#### Using stack + +1. Install [stack] for your platform. +2. Clone this repository. +3. Run `stack setup` (if you're running stack for the first time) and + `stack install`. +4. Make sure `$HOME/.local/bin` is in your `$PATH`. + +[stack]: https://docs.haskellstack.org/en/stable/README/ + +#### Using cabal + +1. Install [cabal] for your platform. +2. Run `cabal install patat`. +3. Make sure `$HOME/.cabal/bin` is in your `$PATH`. + +[cabal]: https://www.haskell.org/cabal/ + +Running +------- + +`patat [*options*] file` + +Options +------- + +`-w`, `--watch` + +: If you provide the `--watch` flag, `patat` will watch the presentation file + for changes and reload automatically. This is very useful when you are + writing the presentation. + +`-f`, `--force` + +: Run the presentation even if the terminal claims it does not support ANSI + features. + +`-d`, `--dump` + +: Just dump all the slides to stdout. This is useful for debugging. + +`--version` + +: Display version information. + +Controls +-------- + +- **Next slide**: `space`, `enter`, `l`, `→`, `PageDown` +- **Previous slide**: `backspace`, `h`, `←`, `PageUp` +- **Go forward 10 slides**: `j`, `↓` +- **Go backward 10 slides**: `k`, `↑` +- **First slide**: `0` +- **Last slide**: `G` +- **Reload file**: `r` +- **Quit**: `q` + +The `r` key is very useful since it allows you to preview your slides while you +are writing them. You can also use this to fix artifacts when the terminal is +resized. + +Input format +------------ + +The input format can be anything that Pandoc supports. Plain markdown is +usually the most simple solution: + +```markdown +--- +title: This is my presentation +author: Jane Doe +... + +# This is a slide + +Slide contents. Yay. + +--- + +# Important title + +Things I like: + +- Markdown +- Haskell +- Pandoc +``` + +Horizontal rulers (`---`) are used to split slides. + +However, if you prefer not use these since they are a bit intrusive in the +markdown, you can also start every slide with a header. In that case, the file +should not contain a single horizontal ruler. + +`patat` will pick the most deeply nested header (e.g. `h2`) as the marker for a +new slide. Headers _above_ the most deeply nested header (e.g. `h1`) will turn +into title slides, which are displayed as as a slide containing only the +centered title. + +This means the following document is equivalent to the one we saw before: + +```markdown +--- +title: This is my presentation +author: Jane Doe +... + +# This is a slide + +Slide contents. Yay. + +# Important title + +Things I like: + +- Markdown +- Haskell +- Pandoc +``` + +And that following document contains three slides: a title slide, followed by +two content slides. + +```markdown +--- +title: This is my presentation +author: Jane Doe +... + +# Chapter 1 + +## This is a slide + +Slide contents. Yay. + +## Another slide + +Things I like: + +- Markdown +- Haskell +- Pandoc +``` + +For more information, see [Advanced slide splitting](#advanced-slide-splitting). + +Patat supports comments which can be used as speaker notes. + +```markdown +--- +title: This is my presentation +author: Jane Doe +... + +# Chapter 1 + + + +Slide contents. Yay. + + +``` + +Configuration +------------- + +`patat` is fairly configurable. The configuration is done using [YAML]. There +are two places where you can put your configuration: + +1. In the presentation file itself, using the [Pandoc metadata header]. +2. In `$HOME/.patat.yaml` + +[YAML]: http://yaml.org/ +[Pandoc metadata header]: http://pandoc.org/MANUAL.html#extension-yaml_metadata_block + +For example, we set an option `key` to `val` by using the following file: + +```markdown +--- +title: Presentation with options +author: John Doe +patat: + key: val +... + +Hello world. +``` + +Or we can use a normal presentation and have the following `$HOME/.patat.yaml`: + + key: val + +### Line wrapping + +Line wrapping can be enabled by setting `wrap: true` in the configuration. This +will re-wrap all lines to fit the terminal width better. + +### Margins + +Margins can be enabled by setting a `margins` entry in the configuration: + +```markdown +--- +title: Presentation with margins +author: John Doe +patat: + wrap: true + margins: + left: 10 + right: 10 +... + +Lorem ipsum dolor sit amet, ... +``` + +This example configuration will generate slides with a margin of 10 characters on the left, +and break lines 10 characters before they reach the end of the terminal's width. + +It is recommended to enable [line wrapping](#line-wrapping) along with this feature. + +### Auto advancing + +By setting `autoAdvanceDelay` to a number of seconds, `patat` will automatically +advance to the next slide. + +```markdown +--- +title: Auto-advance, yes please +author: John Doe +patat: + autoAdvanceDelay: 2 +... + +Hello World! + +--- + +This slide will be shown two seconds after the presentation starts. +``` + +Note that changes to `autoAdvanceDelay` are not picked up automatically if you +are running `patat --watch`. This requires restarting `patat`. + +### Advanced slide splitting + +You can control the way slide splitting works by setting the `slideLevel` +variable. This variable defaults to the least header that occurs before a +non-header, but it can also be explicitly defined. For example, in the +following document, the `slideLevel` defaults to **2**: + +```markdown +# This is a slide + +## This is a nested header + +This is some content +``` + +With `slideLevel` 2, the `h1` will turn into a "title slide", and the `h2` will +be displayed at the top of the second slide. We can customize this by setting +`slideLevel` manually: + +```markdown +--- +patat: + slideLevel: 1 +... + +# This is a slide + +## This is a nested header + +This is some content +``` + +Now, we will only see one slide, which contains a nested header. + +### Fragmented slides + +By default, slides are always displayed "all at once". If you want to display +them fragment by fragment, there are two ways to do that. The most common +case is that lists should be displayed incrementally. + +This can be configured by settings `incrementalLists` to `true` in the metadata +block: + +```markdown +--- +title: Presentation with incremental lists +author: John Doe +patat: + incrementalLists: true +... + +- This list +- is displayed +- item by item +``` + +Setting `incrementalLists` works on _all_ lists in the presentation. To flip +the setting for a specific list, wrap it in a block quote. This will make the +list incremental if `incrementalLists` is not set, and it will display the list +all at once if `incrementalLists` is set to `true`. + +This example contains a sublist which is also displayed incrementally, and then +a sublist which is displayed all at once (by merit of the block quote). + +```markdown +--- +title: Presentation with incremental lists +author: John Doe +patat: + incrementalLists: true +... + +- This list +- is displayed + + * item + * by item + +- Or sometimes + + > * all at + > * once +``` + +Another way to break up slides is to use a pagraph only containing three dots +separated by spaces. For example, this slide has two pauses: + +```markdown +Legen + +. . . + +wait for it + +. . . + +Dary! +``` + +### Theming + +Colors and other properties can also be changed using this configuration. For +example, we can have: + +```markdown +--- +author: 'Jasper Van der Jeugt' +title: 'This is a test' +patat: + wrap: true + theme: + emph: [vividBlue, onVividBlack, italic] + strong: [bold] + imageTarget: [onDullWhite, vividRed] +... + +# This is a presentation + +This is _emph_ text. + +![Hello](foo.png) +``` + +The properties that can be given a list of styles are: + +`blockQuote`, `borders`, `bulletList`, `codeBlock`, `code`, `definitionList`, +`definitionTerm`, `emph`, `header`, `imageTarget`, `imageText`, `linkTarget`, +`linkText`, `math`, `orderedList`, `quoted`, `strikeout`, `strong`, +`tableHeader`, `tableSeparator` + +The accepted styles are: + +`bold`, `italic`, `dullBlack`, `dullBlue`, `dullCyan`, `dullGreen`, +`dullMagenta`, `dullRed`, `dullWhite`, `dullYellow`, `onDullBlack`, +`onDullBlue`, `onDullCyan`, `onDullGreen`, `onDullMagenta`, `onDullRed`, +`onDullWhite`, `onDullYellow`, `onVividBlack`, `onVividBlue`, `onVividCyan`, +`onVividGreen`, `onVividMagenta`, `onVividRed`, `onVividWhite`, `onVividYellow`, +`underline`, `vividBlack`, `vividBlue`, `vividCyan`, `vividGreen`, +`vividMagenta`, `vividRed`, `vividWhite`, `vividYellow` + +Also accepted are styles of the form `rgb#RrGgBb` and `onRgb#RrGgBb`, where `Rr` +`Gg` and `Bb` are hexadecimal bytes (e.g. `rgb#f08000` for an orange foreground, +and `onRgb#101060` for a deep purple background). Naturally, your terminal +needs to support 24-bit RGB for this to work. When creating portable +presentations, it might be better to stick with the named colours listed above. + +### Syntax Highlighting + +As part of theming, syntax highlighting is also configurable. This can be +configured like this: + +```markdown +--- +patat: + theme: + syntaxHighlighting: + decVal: [bold, onDullRed] +... + +... +``` + +`decVal` refers to "decimal values". This is known as a "token type". For a +full list of token types, see [this list] -- the names are derived from there in +an obvious way. + +[this list]: https://hackage.haskell.org/package/highlighting-kate-0.6.3/docs/Text-Highlighting-Kate-Types.html#t:TokenType + +### Pandoc Extensions + +Pandoc comes with a fair number of extensions on top of markdown, listed [here](https://hackage.haskell.org/package/pandoc-2.0.5/docs/Text-Pandoc-Extensions.html). + +`patat` enables a number of them by default, but this is also customizable. + +In order to enable an additional extensions, e.g. `autolink_bare_uris`, add it +to the `pandocExtensions` field in the YAML metadata: + +```markdown +--- +patat: + pandocExtensions: + - patat_extensions + - autolink_bare_uris +... + +Document content... +``` + +The `patat_extensions` in the above snippet refers to the default set of +extensions enabled by `patat`. If you want to disable those and only use a +select few extensions, simply leave it out and choose your own: + +```markdown +--- +patat: + pandocExtensions: + - autolink_bare_uris + - emoji +... + +... + +Document content... +``` + +If you don't want to enable any extensions, simply set `pandocExtensions` to the +empty list `[]`. + + +### Images + +`patat-0.8.0.0` and newer include images support for some terminal emulators. + +```markdown +--- +patat: + images: + backend: auto +... + +# A slide with only an image. + +![](matterhorn.jpg) +``` + +If `images` is enabled (not by default), `patat` will draw slides that consist +only of a single image just by drawing the image, centered and resized to fit +the terminal window. + +`patat` supports the following image drawing backends: + +- `backend: iterm2`: uses [iTerm2](https://iterm2.com/)'s special escape + sequence to render the image. This even works with animated GIFs! + +- `backend: w3m`: uses the `w3mimgdisplay` executable to draw directly onto + the window. This has been tested in `urxvt` and `xterm`, but is known to + produce weird results in `tmux`. + + If `w3mimgdisplay` is in a non-standard location, you can specify that using + `path`: + + ```yaml + backend: 'w3m' + path: '/home/jasper/.local/bin/w3mimgdisplay' + ``` + +Trivia +------ + +_"Patat"_ is the Flemish word for a simple potato. Dutch people also use it to +refer to French Fries but I don't really do that -- in Belgium we just call +fries _"Frieten"_. + +The idea of `patat` is largely based upon [MDP] which is in turn based upon +[VTMC]. I wanted to write a clone using Pandoc because I ran into a markdown +parsing bug in MDP which I could not work around. A second reason to do a +Pandoc-based tool was that I would be able to use [Literate Haskell] as well. +Lastly, I also prefer not to install Node.js on my machine if I can avoid it. + +[MDP]: https://github.com/visit1985/mdp +[VTMC]: https://github.com/jclulow/vtmc +[Literate Haskell]: https://wiki.haskell.org/Literate_programming diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/extra/make-man.hs b/extra/make-man.hs new file mode 100644 index 0000000..cd14cf0 --- /dev/null +++ b/extra/make-man.hs @@ -0,0 +1,122 @@ +-- | This script generates a man page for patat. +{-# LANGUAGE OverloadedStrings #-} +import Control.Applicative ((<$>)) +import Control.Exception (throw) +import Control.Monad (guard) +import Control.Monad.Trans (liftIO) +import Data.Char (isSpace, toLower) +import Data.List (isPrefixOf) +import Data.Maybe (isJust) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified GHC.IO.Encoding as Encoding +import Prelude +import System.Environment (getEnv) +import qualified System.IO as IO +import qualified Data.Time as Time +import qualified Text.Pandoc as Pandoc + +getVersion :: IO String +getVersion = + dropWhile isSpace . drop 1 . dropWhile (/= ':') . head . + filter (\l -> "version:" `isPrefixOf` map toLower l) . + map (dropWhile isSpace) . lines <$> readFile "patat.cabal" + +getPrettySourceDate :: IO String +getPrettySourceDate = do + epoch <- getEnv "SOURCE_DATE_EPOCH" + utc <- Time.parseTimeM True locale "%s" epoch :: IO Time.UTCTime + return $ Time.formatTime locale "%B %d, %Y" utc + where + locale = Time.defaultTimeLocale + +type Sections = [(Int, T.Text, [Pandoc.Block])] + +toSections :: Int -> [Pandoc.Block] -> Sections +toSections level = go + where + go [] = [] + go (h : xs) = case toSectionHeader h of + Nothing -> go xs + Just (l, title) -> + let (section, cont) = break (isJust . toSectionHeader) xs in + (l, title, section) : go cont + + toSectionHeader :: Pandoc.Block -> Maybe (Int, T.Text) + toSectionHeader (Pandoc.Header l _ inlines) = do + guard (l <= level) + let doc = Pandoc.Pandoc Pandoc.nullMeta [Pandoc.Plain inlines] + txt = case Pandoc.runPure (Pandoc.writeMarkdown Pandoc.def doc) of + Left err -> throw err -- Bad! + Right x -> x + return (l, txt) + toSectionHeader _ = Nothing + +fromSections :: Sections -> [Pandoc.Block] +fromSections = concatMap $ \(level, title, blocks) -> + Pandoc.Header level ("", [], []) [Pandoc.Str $ T.unpack title] : blocks + +reorganizeSections :: Pandoc.Pandoc -> Pandoc.Pandoc +reorganizeSections (Pandoc.Pandoc meta0 blocks0) = + let sections0 = toSections 2 blocks0 in + Pandoc.Pandoc meta0 $ fromSections $ + [ (1, "NAME", nameSection) + ] ++ + [ (1, "SYNOPSIS", s) + | (_, _, s) <- lookupSection "Running" sections0 + ] ++ + [ (1, "DESCRIPTION", []) + ] ++ + [ (2, n, s) + | (_, n, s) <- lookupSection "Controls" sections0 + ] ++ + [ (2, n, s) + | (_, n, s) <- lookupSection "Input format" sections0 + ] ++ + [ (2, n, s) + | (_, n, s) <- lookupSection "Configuration" sections0 + ] ++ + [ (1, "OPTIONS", s) + | (_, _, s) <- lookupSection "Options" sections0 + ] ++ + [ (1, "SEE ALSO", seeAlsoSection) + ] + where + nameSection = mkPara "patat - Presentations Atop The ANSI Terminal" + seeAlsoSection = mkPara "pandoc(1)" + mkPara str = [Pandoc.Para [Pandoc.Str str]] + + lookupSection name sections = + [section | section@(_, n, _) <- sections, name == n] + +main :: IO () +main = Pandoc.runIOorExplode $ do + liftIO $ Encoding.setLocaleEncoding Encoding.utf8 + + let readerOptions = Pandoc.def + { Pandoc.readerExtensions = Pandoc.pandocExtensions + } + + source <- liftIO $ T.readFile "README.md" + pandoc0 <- Pandoc.readMarkdown readerOptions source + template <- Pandoc.getDefaultTemplate "man" + + version <- liftIO getVersion + date <- liftIO getPrettySourceDate + + let writerOptions = Pandoc.def + { Pandoc.writerTemplate = Just template + , Pandoc.writerVariables = + [ ("author", "Jasper Van der Jeugt") + , ("title", "patat manual") + , ("date", date) + , ("footer", "patat v" ++ version) + , ("section", "1") + ] + } + + let pandoc1 = reorganizeSections $ pandoc0 + txt <- Pandoc.writeMan writerOptions pandoc1 + liftIO $ do + T.putStr txt + IO.hPutStrLn IO.stderr "Wrote man page." diff --git a/extra/screenshot.png b/extra/screenshot.png new file mode 100644 index 0000000..e20d771 Binary files /dev/null and b/extra/screenshot.png differ diff --git a/patat.cabal b/patat.cabal new file mode 100644 index 0000000..87b0892 --- /dev/null +++ b/patat.cabal @@ -0,0 +1,102 @@ +Name: patat +Version: 0.8.2.1 +Synopsis: Terminal-based presentations using Pandoc +Description: Terminal-based presentations using Pandoc +License: GPL-2 +License-file: LICENSE +Author: Jasper Van der Jeugt +Maintainer: Jasper Van der Jeugt +Homepage: http://github.com/jaspervdj/patat +Copyright: 2016 Jasper Van der Jeugt +Category: Text +Build-type: Simple +Cabal-version: >=1.10 + +Extra-source-files: + CHANGELOG.md + README.md + +Source-repository head + Type: git + Location: git://github.com/jaspervdj/patat.git + +Flag patat-make-man + Description: Build the executable to generate the man page + Default: False + Manual: True + +Executable patat + Main-is: Main.hs + Ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N" + Hs-source-dirs: src + Default-language: Haskell2010 + + Build-depends: + aeson >= 0.9 && < 1.5, + ansi-terminal >= 0.6 && < 0.10, + ansi-wl-pprint >= 0.6 && < 0.7, + base >= 4.6 && < 5, + base64-bytestring >= 1.0 && < 1.1, + bytestring >= 0.10 && < 0.11, + colour >= 2.3 && < 2.4, + containers >= 0.5 && < 0.7, + directory >= 1.2 && < 1.4, + filepath >= 1.4 && < 1.5, + mtl >= 2.2 && < 2.3, + optparse-applicative >= 0.12 && < 0.15, + pandoc >= 2.0.4 && < 2.7, + process >= 1.6 && < 1.7, + skylighting >= 0.1 && < 0.8, + terminal-size >= 0.3 && < 0.4, + text >= 1.2 && < 1.3, + time >= 1.4 && < 1.10, + unordered-containers >= 0.2 && < 0.3, + yaml >= 0.8 && < 0.12, + -- We don't even depend on these packages but they can break cabal install + -- because of the conflicting 'Network.URI' module. + network-uri >= 2.6, + network >= 2.6 + + If impl(ghc < 8.0) + Build-depends: + semigroups >= 0.16 && < 0.19 + + Other-modules: + Data.Aeson.Extended + Data.Aeson.TH.Extended + Data.Data.Extended + Patat.AutoAdvance + Patat.Images + Patat.Images.Internal + Patat.Images.W3m + Patat.Images.ITerm2 + Patat.Presentation + Patat.Presentation.Display + Patat.Presentation.Display.CodeBlock + Patat.Presentation.Display.Table + Patat.Presentation.Fragment + Patat.Presentation.Interactive + Patat.Presentation.Internal + Patat.Presentation.Read + Patat.PrettyPrint + Patat.Theme + Paths_patat + Text.Pandoc.Extended + +Executable patat-make-man + Main-is: make-man.hs + Ghc-options: -Wall + Hs-source-dirs: extra + Default-language: Haskell2010 + + If flag(patat-make-man) + Buildable: True + Else + Buildable: False + + Build-depends: + base >= 4.6 && < 5, + mtl >= 2.2 && < 2.3, + pandoc >= 2.0 && < 2.7, + text >= 1.2 && < 1.3, + time >= 1.6 && < 1.10 diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs new file mode 100644 index 0000000..9b95cec --- /dev/null +++ b/src/Data/Aeson/Extended.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Aeson.Extended + ( module Data.Aeson + + , FlexibleNum (..) + ) where + +import Control.Applicative ((<$>)) +import Data.Aeson +import qualified Data.Text as T +import Text.Read (readMaybe) +import Prelude + +-- | This can be parsed from a JSON string in addition to a JSON number. +newtype FlexibleNum a = FlexibleNum {unFlexibleNum :: a} + deriving (Show, ToJSON) + +instance (FromJSON a, Read a) => FromJSON (FlexibleNum a) where + parseJSON (String str) = case readMaybe (T.unpack str) of + Nothing -> fail $ "Could not parse " ++ T.unpack str ++ " as a number" + Just x -> return (FlexibleNum x) + parseJSON val = FlexibleNum <$> parseJSON val diff --git a/src/Data/Aeson/TH/Extended.hs b/src/Data/Aeson/TH/Extended.hs new file mode 100644 index 0000000..0fa5487 --- /dev/null +++ b/src/Data/Aeson/TH/Extended.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +module Data.Aeson.TH.Extended + ( module Data.Aeson.TH + , dropPrefixOptions + ) where + + +-------------------------------------------------------------------------------- +import Data.Aeson.TH +import Data.Char (isUpper, toLower) + + +-------------------------------------------------------------------------------- +dropPrefixOptions :: Options +dropPrefixOptions = defaultOptions + { fieldLabelModifier = dropPrefix + } + where + dropPrefix str = case break isUpper str of + (_, (y : ys)) -> toLower y : ys + _ -> str diff --git a/src/Data/Data/Extended.hs b/src/Data/Data/Extended.hs new file mode 100644 index 0000000..636591e --- /dev/null +++ b/src/Data/Data/Extended.hs @@ -0,0 +1,23 @@ +module Data.Data.Extended + ( module Data.Data + + , grecQ + , grecT + ) where + +import Data.Data + +-- | Recursively find all values of a certain type. +grecQ :: (Data a, Data b) => a -> [b] +grecQ = concat . gmapQ (\x -> maybe id (:) (cast x) $ grecQ x) + +-- | Recursively apply an update to a certain type. +grecT :: (Data a, Data b) => (a -> a) -> b -> b +grecT f x = gmapT (grecT f) (castMap f x) + +castMap :: (Typeable a, Typeable b) => (a -> a) -> b -> b +castMap f x = case cast x of + Nothing -> x + Just y -> case cast (f y) of + Nothing -> x + Just z -> z diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..f45ae35 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,191 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent (forkIO, threadDelay) +import qualified Control.Concurrent.Chan as Chan +import Control.Exception (finally) +import Control.Monad (forever, unless, when) +import qualified Data.Aeson.Extended as A +import Data.Monoid (mempty, (<>)) +import Data.Time (UTCTime) +import Data.Version (showVersion) +import qualified Options.Applicative as OA +import Patat.AutoAdvance +import qualified Patat.Images as Images +import Patat.Presentation +import qualified Paths_patat +import Prelude +import qualified System.Console.ANSI as Ansi +import System.Directory (doesFileExist, + getModificationTime) +import System.Exit (exitFailure, exitSuccess) +import qualified System.IO as IO +import qualified Text.PrettyPrint.ANSI.Leijen as PP + + +-------------------------------------------------------------------------------- +data Options = Options + { oFilePath :: !(Maybe FilePath) + , oForce :: !Bool + , oDump :: !Bool + , oWatch :: !Bool + , oVersion :: !Bool + } deriving (Show) + + +-------------------------------------------------------------------------------- +parseOptions :: OA.Parser Options +parseOptions = Options + <$> (OA.optional $ OA.strArgument $ + OA.metavar "FILENAME" <> + OA.help "Input file") + <*> (OA.switch $ + OA.long "force" <> + OA.short 'f' <> + OA.help "Force ANSI terminal" <> + OA.hidden) + <*> (OA.switch $ + OA.long "dump" <> + OA.short 'd' <> + OA.help "Just dump all slides and exit" <> + OA.hidden) + <*> (OA.switch $ + OA.long "watch" <> + OA.short 'w' <> + OA.help "Watch file for changes") + <*> (OA.switch $ + OA.long "version" <> + OA.help "Display version info and exit" <> + OA.hidden) + + +-------------------------------------------------------------------------------- +parserInfo :: OA.ParserInfo Options +parserInfo = OA.info (OA.helper <*> parseOptions) $ + OA.fullDesc <> + OA.header ("patat v" <> showVersion Paths_patat.version) <> + OA.progDescDoc (Just desc) + where + desc = PP.vcat + [ "Terminal-based presentations using Pandoc" + , "" + , "Controls:" + , "- Next slide: space, enter, l, right, pagedown" + , "- Previous slide: backspace, h, left, pageup" + , "- Go forward 10 slides: j, down" + , "- Go backward 10 slides: k, up" + , "- First slide: 0" + , "- Last slide: G" + , "- Reload file: r" + , "- Quit: q" + ] + + +-------------------------------------------------------------------------------- +parserPrefs :: OA.ParserPrefs +parserPrefs = OA.prefs OA.showHelpOnError + + +-------------------------------------------------------------------------------- +errorAndExit :: [String] -> IO a +errorAndExit msg = do + mapM_ (IO.hPutStrLn IO.stderr) msg + exitFailure + + +-------------------------------------------------------------------------------- +assertAnsiFeatures :: IO () +assertAnsiFeatures = do + supports <- Ansi.hSupportsANSI IO.stdout + unless supports $ errorAndExit + [ "It looks like your terminal does not support ANSI codes." + , "If you still want to run the presentation, use `--force`." + ] + + +-------------------------------------------------------------------------------- +main :: IO () +main = do + options <- OA.customExecParser parserPrefs parserInfo + + when (oVersion options) $ do + putStrLn (showVersion Paths_patat.version) + exitSuccess + + filePath <- case oFilePath options of + Just fp -> return fp + Nothing -> OA.handleParseResult $ OA.Failure $ + OA.parserFailure parserPrefs parserInfo OA.ShowHelpText mempty + + errOrPres <- readPresentation filePath + pres <- either (errorAndExit . return) return errOrPres + + unless (oForce options) assertAnsiFeatures + + -- (Maybe) initialize images backend. + images <- traverse Images.new (psImages $ pSettings pres) + + if oDump options + then dumpPresentation pres + else interactiveLoop options images pres + where + interactiveLoop :: Options -> Maybe Images.Handle -> Presentation -> IO () + interactiveLoop options images pres0 = (`finally` cleanup) $ do + IO.hSetBuffering IO.stdin IO.NoBuffering + Ansi.hideCursor + + -- Spawn the initial channel that gives us commands based on user input. + commandChan0 <- Chan.newChan + _ <- forkIO $ forever $ + readPresentationCommand >>= Chan.writeChan commandChan0 + + -- If an auto delay is set, use 'autoAdvance' to create a new one. + commandChan <- case psAutoAdvanceDelay (pSettings pres0) of + Nothing -> return commandChan0 + Just (A.FlexibleNum delay) -> autoAdvance delay commandChan0 + + -- Spawn a thread that adds 'Reload' commands based on the file time. + mtime0 <- getModificationTime (pFilePath pres0) + when (oWatch options) $ do + _ <- forkIO $ watcher commandChan (pFilePath pres0) mtime0 + return () + + let loop :: Presentation -> Maybe String -> IO () + loop pres mbError = do + case mbError of + Nothing -> displayPresentation images pres + Just err -> displayPresentationError pres err + + c <- Chan.readChan commandChan + update <- updatePresentation c pres + case update of + ExitedPresentation -> return () + UpdatedPresentation pres' -> loop pres' Nothing + ErroredPresentation err -> loop pres (Just err) + + loop pres0 Nothing + + cleanup :: IO () + cleanup = do + Ansi.showCursor + Ansi.clearScreen + Ansi.setCursorPosition 0 0 + + +-------------------------------------------------------------------------------- +watcher :: Chan.Chan PresentationCommand -> FilePath -> UTCTime -> IO a +watcher chan filePath mtime0 = do + -- The extra exists check helps because some editors temporarily make the + -- file disappear while writing. + exists <- doesFileExist filePath + mtime1 <- if exists then getModificationTime filePath else return mtime0 + + when (mtime1 > mtime0) $ Chan.writeChan chan Reload + threadDelay (200 * 1000) + watcher chan filePath mtime1 diff --git a/src/Patat/AutoAdvance.hs b/src/Patat/AutoAdvance.hs new file mode 100644 index 0000000..236e0cb --- /dev/null +++ b/src/Patat/AutoAdvance.hs @@ -0,0 +1,52 @@ +-------------------------------------------------------------------------------- +module Patat.AutoAdvance + ( autoAdvance + ) where + + +-------------------------------------------------------------------------------- +import Control.Concurrent (forkIO, threadDelay) +import qualified Control.Concurrent.Chan as Chan +import Control.Monad (forever) +import qualified Data.IORef as IORef +import Data.Time (diffUTCTime, getCurrentTime) +import Patat.Presentation (PresentationCommand (..)) + + +-------------------------------------------------------------------------------- +-- | This function takes an existing channel for presentation commands +-- (presumably coming from human input) and creates a new one that /also/ sends +-- a 'Forward' command if nothing happens for N seconds. +autoAdvance + :: Int + -> Chan.Chan PresentationCommand + -> IO (Chan.Chan PresentationCommand) +autoAdvance delaySeconds existingChan = do + let delay = delaySeconds * 1000 -- We are working with ms in this function + + newChan <- Chan.newChan + latestCommandAt <- IORef.newIORef =<< getCurrentTime + + -- This is a thread that copies 'existingChan' to 'newChan', and writes + -- whenever the latest command was to 'latestCommandAt'. + _ <- forkIO $ forever $ do + cmd <- Chan.readChan existingChan + getCurrentTime >>= IORef.writeIORef latestCommandAt + Chan.writeChan newChan cmd + + -- This is a thread that waits around 'delay' seconds and then checks if + -- there's been a more recent command. If not, we write a 'Forward'. + _ <- forkIO $ forever $ do + current <- getCurrentTime + latest <- IORef.readIORef latestCommandAt + let elapsed = floor $ 1000 * (current `diffUTCTime` latest) :: Int + if elapsed >= delay + then do + Chan.writeChan newChan Forward + IORef.writeIORef latestCommandAt current + threadDelay (delay * 1000) + else do + let wait = delay - elapsed + threadDelay (wait * 1000) + + return newChan diff --git a/src/Patat/Images.hs b/src/Patat/Images.hs new file mode 100644 index 0000000..0d048d0 --- /dev/null +++ b/src/Patat/Images.hs @@ -0,0 +1,60 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Patat.Images + ( Backend + , Handle + , new + , drawImage + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (catch) +import qualified Data.Aeson as A +import qualified Data.Text as T +import Patat.Images.Internal +import qualified Patat.Images.ITerm2 as ITerm2 +import qualified Patat.Images.W3m as W3m +import Patat.Presentation.Internal + + +-------------------------------------------------------------------------------- +new :: ImageSettings -> IO Handle +new is + | isBackend is == "auto" = auto + | Just (Backend b) <- lookup (isBackend is) backends = + case A.fromJSON (A.Object $ isParams is) of + A.Success c -> b (Explicit c) + A.Error err -> fail $ + "Patat.Images.new: Error parsing config for " ++ + show (isBackend is) ++ " image backend: " ++ err +new is = fail $ + "Patat.Images.new: Could not find " ++ show (isBackend is) ++ + " image backend." + + +-------------------------------------------------------------------------------- +auto :: IO Handle +auto = go [] backends + where + go names ((name, Backend b) : bs) = catch + (b Auto) + (\(BackendNotSupported _) -> go (name : names) bs) + go names [] = fail $ + "Could not find a supported backend, tried: " ++ + T.unpack (T.intercalate ", " (reverse names)) + + +-------------------------------------------------------------------------------- +-- | All supported backends. We can use CPP to include or exclude some +-- depending on platform availability. +backends :: [(T.Text, Backend)] +backends = + [ ("iterm2", ITerm2.backend) + , ("w3m", W3m.backend) + ] + + +-------------------------------------------------------------------------------- +drawImage :: Handle -> FilePath -> IO () +drawImage = hDrawImage diff --git a/src/Patat/Images/ITerm2.hs b/src/Patat/Images/ITerm2.hs new file mode 100644 index 0000000..2584aed --- /dev/null +++ b/src/Patat/Images/ITerm2.hs @@ -0,0 +1,56 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE TemplateHaskell #-} +module Patat.Images.ITerm2 + ( backend + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (throwIO) +import Control.Monad (unless, when) +import qualified Data.Aeson as A +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.List as L +import qualified Patat.Images.Internal as Internal +import System.Environment (lookupEnv) + + +-------------------------------------------------------------------------------- +backend :: Internal.Backend +backend = Internal.Backend new + + +-------------------------------------------------------------------------------- +data Config = Config deriving (Eq) +instance A.FromJSON Config where parseJSON _ = return Config + + +-------------------------------------------------------------------------------- +new :: Internal.Config Config -> IO Internal.Handle +new config = do + when (config == Internal.Auto) $ do + termProgram <- lookupEnv "TERM_PROGRAM" + unless (termProgram == Just "iTerm.app") $ throwIO $ + Internal.BackendNotSupported "TERM_PROGRAM not iTerm.app" + + return Internal.Handle {Internal.hDrawImage = drawImage} + + +-------------------------------------------------------------------------------- +drawImage :: FilePath -> IO () +drawImage path = do + content <- BL.readFile path + withEscapeSequence $ do + putStr "1337;File=inline=1;width=100%;height=100%:" + BL.putStr (B64.encode content) + + +-------------------------------------------------------------------------------- +withEscapeSequence :: IO () -> IO () +withEscapeSequence f = do + term <- lookupEnv "TERM" + let inScreen = maybe False ("screen" `L.isPrefixOf`) term + putStr $ if inScreen then "\ESCPtmux;\ESC\ESC]" else "\ESC]" + f + putStrLn $ if inScreen then "\a\ESC\\" else "\a" diff --git a/src/Patat/Images/Internal.hs b/src/Patat/Images/Internal.hs new file mode 100644 index 0000000..939f962 --- /dev/null +++ b/src/Patat/Images/Internal.hs @@ -0,0 +1,39 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +module Patat.Images.Internal + ( Config (..) + , Backend (..) + , BackendNotSupported (..) + , Handle (..) + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (Exception) +import qualified Data.Aeson as A +import Data.Data (Data) +import Data.Typeable (Typeable) + + +-------------------------------------------------------------------------------- +data Config a = Auto | Explicit a deriving (Eq) + + +-------------------------------------------------------------------------------- +data Backend = forall a. A.FromJSON a => Backend (Config a -> IO Handle) + + +-------------------------------------------------------------------------------- +data BackendNotSupported = BackendNotSupported String + deriving (Data, Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Exception BackendNotSupported + + +-------------------------------------------------------------------------------- +data Handle = Handle + { hDrawImage :: FilePath -> IO () + } diff --git a/src/Patat/Images/W3m.hs b/src/Patat/Images/W3m.hs new file mode 100644 index 0000000..d2ae171 --- /dev/null +++ b/src/Patat/Images/W3m.hs @@ -0,0 +1,145 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE TemplateHaskell #-} +module Patat.Images.W3m + ( backend + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (throwIO) +import Control.Monad (unless) +import qualified Data.Aeson.TH.Extended as A +import qualified Patat.Images.Internal as Internal +import qualified System.Directory as Directory +import qualified System.Process as Process +import Text.Read (readMaybe) + + +-------------------------------------------------------------------------------- +backend :: Internal.Backend +backend = Internal.Backend new + + +-------------------------------------------------------------------------------- +data Config = Config + { cPath :: Maybe FilePath + } deriving (Show) + + +-------------------------------------------------------------------------------- +new :: Internal.Config Config -> IO Internal.Handle +new config = do + w3m <- findW3m $ case config of + Internal.Explicit c -> cPath c + _ -> Nothing + + return Internal.Handle {Internal.hDrawImage = drawImage w3m} + + +-------------------------------------------------------------------------------- +newtype W3m = W3m FilePath deriving (Show) + + +-------------------------------------------------------------------------------- +findW3m :: Maybe FilePath -> IO W3m +findW3m mbPath + | Just path <- mbPath = do + exe <- isExecutable path + if exe + then return (W3m path) + else throwIO $ + Internal.BackendNotSupported $ path ++ " is not executable" + | otherwise = W3m <$> find paths + where + find [] = throwIO $ Internal.BackendNotSupported + "w3mimgdisplay executable not found" + find (p : ps) = do + exe <- isExecutable p + if exe then return p else find ps + + paths = + [ "/usr/lib/w3m/w3mimgdisplay" + , "/usr/libexec/w3m/w3mimgdisplay" + , "/usr/lib64/w3m/w3mimgdisplay" + , "/usr/libexec64/w3m/w3mimgdisplay" + , "/usr/local/libexec/w3m/w3mimgdisplay" + ] + + isExecutable path = do + exists <- Directory.doesFileExist path + if exists then do + perms <- Directory.getPermissions path + return (Directory.executable perms) + else + return False + + +-------------------------------------------------------------------------------- +-- | Parses something of the form " \n". +parseWidthHeight :: String -> Maybe (Int, Int) +parseWidthHeight output = case words output of + [ws, hs] | Just w <- readMaybe ws, Just h <- readMaybe hs -> + return (w, h) + _ -> Nothing + + +-------------------------------------------------------------------------------- +getTerminalSize :: W3m -> IO (Int, Int) +getTerminalSize (W3m w3mPath) = do + output <- Process.readProcess w3mPath ["-test"] "" + case parseWidthHeight output of + Just wh -> return wh + _ -> fail $ + "Patat.Images.W3m.getTerminalSize: " ++ + "Could not parse `w3mimgdisplay -test` output" + + +-------------------------------------------------------------------------------- +getImageSize :: W3m -> FilePath -> IO (Int, Int) +getImageSize (W3m w3mPath) path = do + output <- Process.readProcess w3mPath [] ("5;" ++ path ++ "\n") + case parseWidthHeight output of + Just wh -> return wh + _ -> fail $ + "Patat.Images.W3m.getImageSize: " ++ + "Could not parse image size using `w3mimgdisplay` for " ++ + path + + +-------------------------------------------------------------------------------- +drawImage :: W3m -> FilePath -> IO () +drawImage w3m@(W3m w3mPath) path = do + exists <- Directory.doesFileExist path + unless exists $ fail $ + "Patat.Images.W3m.drawImage: file does not exist: " ++ path + + tsize <- getTerminalSize w3m + isize <- getImageSize w3m path + let (x, y, w, h) = fit tsize isize + command = + "0;1;" ++ + show x ++ ";" ++ show y ++ ";" ++ show w ++ ";" ++ show h ++ + ";;;;;" ++ path ++ "\n4;\n3;\n" + + _ <- Process.readProcess w3mPath [] command + return () + where + fit :: (Int, Int) -> (Int, Int) -> (Int, Int, Int, Int) + fit (tw, th) (iw0, ih0) = + -- Scale down to width + let iw1 = if iw0 > tw then tw else iw0 + ih1 = if iw0 > tw then ((ih0 * tw) `div` iw0) else ih0 + + -- Scale down to height + iw2 = if ih1 > th then ((iw1 * th) `div` ih1) else iw1 + ih2 = if ih1 > th then th else ih1 + + -- Find position + x = (tw - iw2) `div` 2 + y = (th - ih2) `div` 2 in + + (x, y, iw2, ih2) + + +-------------------------------------------------------------------------------- +$(A.deriveFromJSON A.dropPrefixOptions ''Config) diff --git a/src/Patat/Presentation.hs b/src/Patat/Presentation.hs new file mode 100644 index 0000000..8da5a30 --- /dev/null +++ b/src/Patat/Presentation.hs @@ -0,0 +1,20 @@ +module Patat.Presentation + ( PresentationSettings (..) + , defaultPresentationSettings + + , Presentation (..) + , readPresentation + , displayPresentation + , displayPresentationError + , dumpPresentation + + , PresentationCommand (..) + , readPresentationCommand + , UpdatedPresentation (..) + , updatePresentation + ) where + +import Patat.Presentation.Display +import Patat.Presentation.Interactive +import Patat.Presentation.Internal +import Patat.Presentation.Read diff --git a/src/Patat/Presentation/Display.hs b/src/Patat/Presentation/Display.hs new file mode 100644 index 0000000..4e42c70 --- /dev/null +++ b/src/Patat/Presentation/Display.hs @@ -0,0 +1,377 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Display + ( displayPresentation + , displayPresentationError + , dumpPresentation + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Monad (mplus, unless) +import qualified Data.Aeson.Extended as A +import Data.Data.Extended (grecQ) +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import Data.Monoid (mconcat, mempty, (<>)) +import qualified Data.Text as T +import qualified Patat.Images as Images +import Patat.Presentation.Display.CodeBlock +import Patat.Presentation.Display.Table +import Patat.Presentation.Internal +import Patat.PrettyPrint ((<$$>), (<+>)) +import qualified Patat.PrettyPrint as PP +import Patat.Theme (Theme (..)) +import qualified Patat.Theme as Theme +import Prelude +import qualified System.Console.ANSI as Ansi +import qualified System.Console.Terminal.Size as Terminal +import qualified System.IO as IO +import qualified Text.Pandoc.Extended as Pandoc + + +-------------------------------------------------------------------------------- +data CanvasSize = CanvasSize {csRows :: Int, csCols :: Int} deriving (Show) + + +-------------------------------------------------------------------------------- +-- | Display something within the presentation borders that draw the title and +-- the active slide number and so on. +displayWithBorders + :: Presentation -> (CanvasSize -> Theme -> PP.Doc) -> IO () +displayWithBorders Presentation {..} f = do + Ansi.clearScreen + Ansi.setCursorPosition 0 0 + + -- Get terminal width/title + mbWindow <- Terminal.size + let columns = fromMaybe 72 $ + (A.unFlexibleNum <$> psColumns pSettings) `mplus` + (Terminal.width <$> mbWindow) + rows = fromMaybe 24 $ + (A.unFlexibleNum <$> psRows pSettings) `mplus` + (Terminal.height <$> mbWindow) + + let settings = pSettings {psColumns = Just $ A.FlexibleNum columns} + theme = fromMaybe Theme.defaultTheme (psTheme settings) + title = PP.toString (prettyInlines theme pTitle) + titleWidth = length title + titleOffset = (columns - titleWidth) `div` 2 + borders = themed (themeBorders theme) + + unless (null title) $ do + let titleRemainder = columns - titleWidth - titleOffset + wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder + PP.putDoc $ borders wrappedTitle + putStrLn "" + putStrLn "" + + let canvasSize = CanvasSize (rows - 2) columns + PP.putDoc $ formatWith settings $ f canvasSize theme + putStrLn "" + + let (sidx, _) = pActiveFragment + active = show (sidx + 1) ++ " / " ++ show (length pSlides) + activeWidth = length active + author = PP.toString (prettyInlines theme pAuthor) + authorWidth = length author + middleSpaces = PP.spaces $ columns - activeWidth - authorWidth - 2 + + Ansi.setCursorPosition (rows - 1) 0 + PP.putDoc $ borders $ PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space + IO.hFlush IO.stdout + + +-------------------------------------------------------------------------------- +displayImage :: Images.Handle -> FilePath -> IO () +displayImage images path = do + Ansi.clearScreen + Ansi.setCursorPosition 0 0 + putStrLn "" + IO.hFlush IO.stdout + Images.drawImage images path + + +-------------------------------------------------------------------------------- +displayPresentation :: Maybe Images.Handle -> Presentation -> IO () +displayPresentation mbImages pres@Presentation {..} = + case getActiveFragment pres of + Nothing -> displayWithBorders pres mempty + Just (ActiveContent fragment) + | Just images <- mbImages + , Just image <- onlyImage fragment -> + displayImage images image + Just (ActiveContent fragment) -> + displayWithBorders pres $ \_canvasSize theme -> + prettyFragment theme fragment + Just (ActiveTitle block) -> + displayWithBorders pres $ \canvasSize theme -> + let pblock = prettyBlock theme block + (prows, pcols) = PP.dimensions pblock + (mLeft, mRight) = marginsOf pSettings + offsetRow = (csRows canvasSize `div` 2) - (prows `div` 2) + offsetCol = ((csCols canvasSize - mLeft - mRight) `div` 2) - (pcols `div` 2) + spaces = PP.NotTrimmable $ PP.spaces offsetCol in + mconcat (replicate (offsetRow - 3) PP.hardline) <$$> + PP.indent spaces spaces pblock + + where + -- Check if the fragment consists of just a single image, or a header and + -- some image. + onlyImage (Fragment blocks) + | [Pandoc.Para para] <- filter isVisibleBlock blocks + , [Pandoc.Image _ _ (target, _)] <- para = + Just target + onlyImage (Fragment blocks) + | [Pandoc.Header _ _ _, Pandoc.Para para] <- filter isVisibleBlock blocks + , [Pandoc.Image _ _ (target, _)] <- para = + Just target + onlyImage _ = Nothing + + +-------------------------------------------------------------------------------- +-- | Displays an error in the place of the presentation. This is useful if we +-- want to display an error but keep the presentation running. +displayPresentationError :: Presentation -> String -> IO () +displayPresentationError pres err = displayWithBorders pres $ \_ Theme {..} -> + themed themeStrong "Error occurred in the presentation:" <$$> + "" <$$> + (PP.string err) + + +-------------------------------------------------------------------------------- +dumpPresentation :: Presentation -> IO () +dumpPresentation pres = + let settings = pSettings pres + theme = fromMaybe Theme.defaultTheme (psTheme $ settings) in + PP.putDoc $ formatWith settings $ + PP.vcat $ L.intersperse "----------" $ do + slide <- pSlides pres + return $ case slide of + TitleSlide block -> "~~~title" <$$> prettyBlock theme block + ContentSlide fragments -> PP.vcat $ L.intersperse "~~~frag" $ do + fragment <- fragments + return $ prettyFragment theme fragment + + +-------------------------------------------------------------------------------- +formatWith :: PresentationSettings -> PP.Doc -> PP.Doc +formatWith ps = wrap . indent + where + (marginLeft, marginRight) = marginsOf ps + wrap = case (psWrap ps, psColumns ps) of + (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just $ col - marginRight) + _ -> id + spaces = PP.NotTrimmable $ PP.spaces marginLeft + indent = PP.indent spaces spaces + +-------------------------------------------------------------------------------- +prettyFragment :: Theme -> Fragment -> PP.Doc +prettyFragment theme fragment@(Fragment blocks) = + prettyBlocks theme blocks <> + case prettyReferences theme fragment of + [] -> mempty + refs -> PP.hardline <> PP.vcat refs + + +-------------------------------------------------------------------------------- +prettyBlock :: Theme -> Pandoc.Block -> PP.Doc + +prettyBlock theme (Pandoc.Plain inlines) = prettyInlines theme inlines + +prettyBlock theme (Pandoc.Para inlines) = + prettyInlines theme inlines <> PP.hardline + +prettyBlock theme@Theme {..} (Pandoc.Header i _ inlines) = + themed themeHeader (PP.string (replicate i '#') <+> prettyInlines theme inlines) <> + PP.hardline + +prettyBlock theme (Pandoc.CodeBlock (_, classes, _) txt) = + prettyCodeBlock theme classes txt + +prettyBlock theme (Pandoc.BulletList bss) = PP.vcat + [ PP.indent + (PP.NotTrimmable $ themed (themeBulletList theme) prefix) + (PP.Trimmable " ") + (prettyBlocks theme' bs) + | bs <- bss + ] <> PP.hardline + where + prefix = " " <> PP.string [marker] <> " " + marker = case T.unpack <$> themeBulletListMarkers theme of + Just (x : _) -> x + _ -> '-' + + -- Cycle the markers. + theme' = theme + { themeBulletListMarkers = + (\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme + } + +prettyBlock theme@Theme {..} (Pandoc.OrderedList _ bss) = PP.vcat + [ PP.indent + (PP.NotTrimmable $ themed themeOrderedList $ PP.string prefix) + (PP.Trimmable " ") + (prettyBlocks theme bs) + | (prefix, bs) <- zip padded bss + ] <> PP.hardline + where + padded = [n ++ replicate (4 - length n) ' ' | n <- numbers] + numbers = + [ show i ++ "." + | i <- [1 .. length bss] + ] + +prettyBlock _theme (Pandoc.RawBlock _ t) = PP.string t <> PP.hardline + +prettyBlock _theme Pandoc.HorizontalRule = "---" + +prettyBlock theme@Theme {..} (Pandoc.BlockQuote bs) = + let quote = PP.NotTrimmable (themed themeBlockQuote "> ") in + PP.indent quote quote (prettyBlocks theme bs) + +prettyBlock theme@Theme {..} (Pandoc.DefinitionList terms) = + PP.vcat $ map prettyDefinition terms + where + prettyDefinition (term, definitions) = + themed themeDefinitionTerm (prettyInlines theme term) <$$> + PP.hardline <> PP.vcat + [ PP.indent + (PP.NotTrimmable (themed themeDefinitionList ": ")) + (PP.Trimmable " ") $ + prettyBlocks theme (Pandoc.plainToPara definition) + | definition <- definitions + ] + +prettyBlock theme (Pandoc.Table caption aligns _ headers rows) = + PP.wrapAt Nothing $ + prettyTable theme Table + { tCaption = prettyInlines theme caption + , tAligns = map align aligns + , tHeaders = map (prettyBlocks theme) headers + , tRows = map (map (prettyBlocks theme)) rows + } + where + align Pandoc.AlignLeft = PP.AlignLeft + align Pandoc.AlignCenter = PP.AlignCenter + align Pandoc.AlignDefault = PP.AlignLeft + align Pandoc.AlignRight = PP.AlignRight + +prettyBlock theme (Pandoc.Div _attrs blocks) = prettyBlocks theme blocks + +prettyBlock _theme Pandoc.Null = mempty + +#if MIN_VERSION_pandoc(1,18,0) +-- 'LineBlock' elements are new in pandoc-1.18 +prettyBlock theme@Theme {..} (Pandoc.LineBlock inliness) = + let ind = PP.NotTrimmable (themed themeLineBlock "| ") in + PP.wrapAt Nothing $ + PP.indent ind ind $ + PP.vcat $ + map (prettyInlines theme) inliness +#endif + + +-------------------------------------------------------------------------------- +prettyBlocks :: Theme -> [Pandoc.Block] -> PP.Doc +prettyBlocks theme = PP.vcat . map (prettyBlock theme) . filter isVisibleBlock + + +-------------------------------------------------------------------------------- +prettyInline :: Theme -> Pandoc.Inline -> PP.Doc + +prettyInline _theme Pandoc.Space = PP.space + +prettyInline _theme (Pandoc.Str str) = PP.string str + +prettyInline theme@Theme {..} (Pandoc.Emph inlines) = + themed themeEmph $ + prettyInlines theme inlines + +prettyInline theme@Theme {..} (Pandoc.Strong inlines) = + themed themeStrong $ + prettyInlines theme inlines + +prettyInline Theme {..} (Pandoc.Code _ txt) = + themed themeCode $ + PP.string (" " <> txt <> " ") + +prettyInline theme@Theme {..} link@(Pandoc.Link _attrs text (target, _title)) + | isReferenceLink link = + "[" <> themed themeLinkText (prettyInlines theme text) <> "]" + | otherwise = + "<" <> themed themeLinkTarget (PP.string target) <> ">" + +prettyInline _theme Pandoc.SoftBreak = PP.softline + +prettyInline _theme Pandoc.LineBreak = PP.hardline + +prettyInline theme@Theme {..} (Pandoc.Strikeout t) = + "~~" <> themed themeStrikeout (prettyInlines theme t) <> "~~" + +prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.SingleQuote t) = + "'" <> themed themeQuoted (prettyInlines theme t) <> "'" +prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.DoubleQuote t) = + "'" <> themed themeQuoted (prettyInlines theme t) <> "'" + +prettyInline Theme {..} (Pandoc.Math _ t) = + themed themeMath (PP.string t) + +prettyInline theme@Theme {..} (Pandoc.Image _attrs text (target, _title)) = + "![" <> themed themeImageText (prettyInlines theme text) <> "](" <> + themed themeImageTarget (PP.string target) <> ")" + +-- These elements aren't really supported. +prettyInline theme (Pandoc.Cite _ t) = prettyInlines theme t +prettyInline theme (Pandoc.Span _ t) = prettyInlines theme t +prettyInline _theme (Pandoc.RawInline _ t) = PP.string t +prettyInline theme (Pandoc.Note t) = prettyBlocks theme t +prettyInline theme (Pandoc.Superscript t) = prettyInlines theme t +prettyInline theme (Pandoc.Subscript t) = prettyInlines theme t +prettyInline theme (Pandoc.SmallCaps t) = prettyInlines theme t +-- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported + + +-------------------------------------------------------------------------------- +prettyInlines :: Theme -> [Pandoc.Inline] -> PP.Doc +prettyInlines theme = mconcat . map (prettyInline theme) + + +-------------------------------------------------------------------------------- +prettyReferences :: Theme -> Fragment -> [PP.Doc] +prettyReferences theme@Theme {..} = + map prettyReference . getReferences . unFragment + where + getReferences :: [Pandoc.Block] -> [Pandoc.Inline] + getReferences = filter isReferenceLink . grecQ + + prettyReference :: Pandoc.Inline -> PP.Doc + prettyReference (Pandoc.Link _attrs text (target, title)) = + "[" <> + themed themeLinkText (prettyInlines theme $ Pandoc.newlineToSpace text) <> + "](" <> + themed themeLinkTarget (PP.string target) <> + (if null title + then mempty + else PP.space <> "\"" <> PP.string title <> "\"") + <> ")" + prettyReference _ = mempty + + +-------------------------------------------------------------------------------- +isReferenceLink :: Pandoc.Inline -> Bool +isReferenceLink (Pandoc.Link _attrs text (target, _)) = + [Pandoc.Str target] /= text +isReferenceLink _ = False + + +-------------------------------------------------------------------------------- +isVisibleBlock :: Pandoc.Block -> Bool +isVisibleBlock Pandoc.Null = False +isVisibleBlock (Pandoc.RawBlock (Pandoc.Format "html") t) = + not ("" `L.isSuffixOf` t) +isVisibleBlock _ = True diff --git a/src/Patat/Presentation/Display/CodeBlock.hs b/src/Patat/Presentation/Display/CodeBlock.hs new file mode 100644 index 0000000..149bc68 --- /dev/null +++ b/src/Patat/Presentation/Display/CodeBlock.hs @@ -0,0 +1,83 @@ +-------------------------------------------------------------------------------- +-- | Displaying code blocks, optionally with syntax highlighting. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Display.CodeBlock + ( prettyCodeBlock + ) where + + +-------------------------------------------------------------------------------- +import Data.Maybe (mapMaybe) +import Data.Monoid (mconcat, (<>)) +import qualified Data.Text as T +import Patat.Presentation.Display.Table (themed) +import qualified Patat.PrettyPrint as PP +import Patat.Theme +import Prelude +import qualified Skylighting as Skylighting + + +-------------------------------------------------------------------------------- +highlight :: [String] -> String -> [Skylighting.SourceLine] +highlight classes rawCodeBlock = case mapMaybe getSyntax classes of + [] -> zeroHighlight rawCodeBlock + (syn : _) -> + case Skylighting.tokenize config syn (T.pack rawCodeBlock) of + Left _ -> zeroHighlight rawCodeBlock + Right sl -> sl + where + getSyntax :: String -> Maybe Skylighting.Syntax + getSyntax c = Skylighting.lookupSyntax (T.pack c) syntaxMap + + config :: Skylighting.TokenizerConfig + config = Skylighting.TokenizerConfig + { Skylighting.syntaxMap = syntaxMap + , Skylighting.traceOutput = False + } + + syntaxMap :: Skylighting.SyntaxMap + syntaxMap = Skylighting.defaultSyntaxMap + + +-------------------------------------------------------------------------------- +-- | This does fake highlighting, everything becomes a normal token. That makes +-- things a bit easier, since we only need to deal with one cases in the +-- renderer. +zeroHighlight :: String -> [Skylighting.SourceLine] +zeroHighlight str = + [[(Skylighting.NormalTok, T.pack line)] | line <- lines str] + + +-------------------------------------------------------------------------------- +prettyCodeBlock :: Theme -> [String] -> String -> PP.Doc +prettyCodeBlock theme@Theme {..} classes rawCodeBlock = + PP.vcat (map blockified sourceLines) <> + PP.hardline + where + sourceLines :: [Skylighting.SourceLine] + sourceLines = + [[]] ++ highlight classes rawCodeBlock ++ [[]] + + prettySourceLine :: Skylighting.SourceLine -> PP.Doc + prettySourceLine = mconcat . map prettyToken + + prettyToken :: Skylighting.Token -> PP.Doc + prettyToken (tokenType, str) = + themed (syntaxHighlight theme tokenType) (PP.string $ T.unpack str) + + sourceLineLength :: Skylighting.SourceLine -> Int + sourceLineLength line = sum [T.length str | (_, str) <- line] + + blockWidth :: Int + blockWidth = foldr max 0 (map sourceLineLength sourceLines) + + blockified :: Skylighting.SourceLine -> PP.Doc + blockified line = + let len = sourceLineLength line + indent = PP.NotTrimmable " " in + PP.indent indent indent $ + themed themeCodeBlock $ + " " <> + prettySourceLine line <> + PP.string (replicate (blockWidth - len) ' ') <> " " diff --git a/src/Patat/Presentation/Display/Table.hs b/src/Patat/Presentation/Display/Table.hs new file mode 100644 index 0000000..fee68c9 --- /dev/null +++ b/src/Patat/Presentation/Display/Table.hs @@ -0,0 +1,107 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Display.Table + ( Table (..) + , prettyTable + + , themed + ) where + + +-------------------------------------------------------------------------------- +import Data.List (intersperse, transpose) +import Data.Monoid (mconcat, mempty, (<>)) +import Patat.PrettyPrint ((<$$>)) +import qualified Patat.PrettyPrint as PP +import Patat.Theme (Theme (..)) +import qualified Patat.Theme as Theme +import Prelude + + +-------------------------------------------------------------------------------- +data Table = Table + { tCaption :: PP.Doc + , tAligns :: [PP.Alignment] + , tHeaders :: [PP.Doc] + , tRows :: [[PP.Doc]] + } + + +-------------------------------------------------------------------------------- +prettyTable + :: Theme -> Table -> PP.Doc +prettyTable theme@Theme {..} Table {..} = + PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $ + lineIf (not isHeaderLess) (hcat2 headerHeight + [ themed themeTableHeader (PP.align w a (vpad headerHeight header)) + | (w, a, header) <- zip3 columnWidths tAligns tHeaders + ]) <> + dashedHeaderSeparator theme columnWidths <$$> + joinRows + [ hcat2 rowHeight + [ PP.align w a (vpad rowHeight cell) + | (w, a, cell) <- zip3 columnWidths tAligns row + ] + | (rowHeight, row) <- zip rowHeights tRows + ] <$$> + lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <> + lineIf + (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption) + where + lineIf cond line = if cond then line <> PP.hardline else mempty + + joinRows + | all (all isSimpleCell) tRows = PP.vcat + | otherwise = PP.vcat . intersperse "" + + isHeaderLess = all PP.null tHeaders + + headerDimensions = map PP.dimensions tHeaders :: [(Int, Int)] + rowDimensions = map (map PP.dimensions) tRows :: [[(Int, Int)]] + + columnWidths :: [Int] + columnWidths = + [ safeMax (map snd col) + | col <- transpose (headerDimensions : rowDimensions) + ] + + rowHeights = map (safeMax . map fst) rowDimensions :: [Int] + headerHeight = safeMax (map fst headerDimensions) :: Int + + vpad :: Int -> PP.Doc -> PP.Doc + vpad height doc = + let (actual, _) = PP.dimensions doc in + doc <> mconcat (replicate (height - actual) PP.hardline) + + safeMax = foldr max 0 + + hcat2 :: Int -> [PP.Doc] -> PP.Doc + hcat2 rowHeight = PP.paste . intersperse (spaces2 rowHeight) + + spaces2 :: Int -> PP.Doc + spaces2 rowHeight = + mconcat $ intersperse PP.hardline $ + replicate rowHeight (PP.string " ") + + +-------------------------------------------------------------------------------- +isSimpleCell :: PP.Doc -> Bool +isSimpleCell = (<= 1) . fst . PP.dimensions + + +-------------------------------------------------------------------------------- +dashedHeaderSeparator :: Theme -> [Int] -> PP.Doc +dashedHeaderSeparator Theme {..} columnWidths = + mconcat $ intersperse (PP.string " ") + [ themed themeTableSeparator (PP.string (replicate w '-')) + | w <- columnWidths + ] + + +-------------------------------------------------------------------------------- +-- | This does not really belong in the module. +themed :: Maybe Theme.Style -> PP.Doc -> PP.Doc +themed Nothing = id +themed (Just (Theme.Style [])) = id +themed (Just (Theme.Style codes)) = PP.ansi codes diff --git a/src/Patat/Presentation/Fragment.hs b/src/Patat/Presentation/Fragment.hs new file mode 100644 index 0000000..0908381 --- /dev/null +++ b/src/Patat/Presentation/Fragment.hs @@ -0,0 +1,134 @@ +-- | For background info on the spec, see the "Incremental lists" section of the +-- the pandoc manual. +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +module Patat.Presentation.Fragment + ( FragmentSettings (..) + , fragmentBlocks + , fragmentBlock + ) where + +import Data.Foldable (Foldable) +import Data.List (foldl', intersperse) +import Data.Maybe (fromMaybe) +import Data.Traversable (Traversable) +import Prelude +import qualified Text.Pandoc as Pandoc + +data FragmentSettings = FragmentSettings + { fsIncrementalLists :: !Bool + } deriving (Show) + +-- fragmentBlocks :: [Pandoc.Block] -> [[Pandoc.Block]] +-- fragmentBlocks = NonEmpty.toList . joinFragmentedBlocks . map fragmentBlock +fragmentBlocks :: FragmentSettings -> [Pandoc.Block] -> [[Pandoc.Block]] +fragmentBlocks fs blocks0 = + case joinFragmentedBlocks (map (fragmentBlock fs) blocks0) of + Unfragmented bs -> [bs] + Fragmented xs bs -> map (fromMaybe []) xs ++ [fromMaybe [] bs] + +-- | This is all the ways we can "present" a block, after splitting in +-- fragments. +-- +-- In the simplest (and most common case) a block can only be presented in a +-- single way ('Unfragmented'). +-- +-- Alternatively, we might want to show different (partial) versions of the +-- block first before showing the final complete one. These partial or complete +-- versions can be empty, hence the 'Maybe'. +-- +-- For example, imagine that we display the following bullet list incrementally: +-- +-- > [1, 2, 3] +-- +-- Then we would get something like: +-- +-- > Fragmented [Nothing, Just [1], Just [1, 2]] (Just [1, 2, 3]) +data Fragmented a + = Unfragmented a + | Fragmented [Maybe a] (Maybe a) + deriving (Functor, Foldable, Show, Traversable) + +fragmentBlock :: FragmentSettings -> Pandoc.Block -> Fragmented Pandoc.Block +fragmentBlock _fs block@(Pandoc.Para inlines) + | inlines == threeDots = Fragmented [Nothing] Nothing + | otherwise = Unfragmented block + where + threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".") + +fragmentBlock fs (Pandoc.BulletList bs0) = + fragmentList fs (fsIncrementalLists fs) Pandoc.BulletList bs0 + +fragmentBlock fs (Pandoc.OrderedList attr bs0) = + fragmentList fs (fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0 + +fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) = + fragmentList fs (not $ fsIncrementalLists fs) Pandoc.BulletList bs0 + +fragmentBlock fs (Pandoc.BlockQuote [Pandoc.OrderedList attr bs0]) = + fragmentList fs (not $ fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0 + +fragmentBlock _ block@(Pandoc.BlockQuote _) = Unfragmented block + +fragmentBlock _ block@(Pandoc.Header _ _ _) = Unfragmented block +fragmentBlock _ block@(Pandoc.Plain _) = Unfragmented block +fragmentBlock _ block@(Pandoc.CodeBlock _ _) = Unfragmented block +fragmentBlock _ block@(Pandoc.RawBlock _ _) = Unfragmented block +fragmentBlock _ block@(Pandoc.DefinitionList _) = Unfragmented block +fragmentBlock _ block@(Pandoc.Table _ _ _ _ _) = Unfragmented block +fragmentBlock _ block@(Pandoc.Div _ _) = Unfragmented block +fragmentBlock _ block@Pandoc.HorizontalRule = Unfragmented block +fragmentBlock _ block@Pandoc.Null = Unfragmented block + +#if MIN_VERSION_pandoc(1,18,0) +fragmentBlock _ block@(Pandoc.LineBlock _) = Unfragmented block +#endif + +joinFragmentedBlocks :: [Fragmented block] -> Fragmented [block] +joinFragmentedBlocks = + foldl' append (Unfragmented []) + where + append (Unfragmented xs) (Unfragmented y) = + Unfragmented (xs ++ [y]) + + append (Fragmented xs x) (Unfragmented y) = + Fragmented xs (appendMaybe x (Just y)) + + append (Unfragmented x) (Fragmented ys y) = + Fragmented + [appendMaybe (Just x) y' | y' <- ys] + (appendMaybe (Just x) y) + + append (Fragmented xs x) (Fragmented ys y) = + Fragmented + (xs ++ [appendMaybe x y' | y' <- ys]) + (appendMaybe x y) + + appendMaybe :: Maybe [a] -> Maybe a -> Maybe [a] + appendMaybe Nothing Nothing = Nothing + appendMaybe Nothing (Just x) = Just [x] + appendMaybe (Just xs) Nothing = Just xs + appendMaybe (Just xs) (Just x) = Just (xs ++ [x]) + +fragmentList + :: FragmentSettings -- ^ Global settings + -> Bool -- ^ Fragment THIS list? + -> ([[Pandoc.Block]] -> Pandoc.Block) -- ^ List constructor + -> [[Pandoc.Block]] -- ^ List items + -> Fragmented Pandoc.Block -- ^ Resulting list +fragmentList fs fragmentThisList constructor blocks0 = + fmap constructor fragmented + where + -- The fragmented list per list item. + items :: [Fragmented [Pandoc.Block]] + items = map (joinFragmentedBlocks . map (fragmentBlock fs)) blocks0 + + fragmented :: Fragmented [[Pandoc.Block]] + fragmented = joinFragmentedBlocks $ + map (if fragmentThisList then insertPause else id) items + + insertPause :: Fragmented a -> Fragmented a + insertPause (Unfragmented x) = Fragmented [Nothing] (Just x) + insertPause (Fragmented xs x) = Fragmented (Nothing : xs) x diff --git a/src/Patat/Presentation/Interactive.hs b/src/Patat/Presentation/Interactive.hs new file mode 100644 index 0000000..d3977e3 --- /dev/null +++ b/src/Patat/Presentation/Interactive.hs @@ -0,0 +1,126 @@ +-------------------------------------------------------------------------------- +-- | Module that allows the user to interact with the presentation +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Interactive + ( PresentationCommand (..) + , readPresentationCommand + + , UpdatedPresentation (..) + , updatePresentation + ) where + + +-------------------------------------------------------------------------------- +import Patat.Presentation.Internal +import Patat.Presentation.Read + + +-------------------------------------------------------------------------------- +data PresentationCommand + = Exit + | Forward + | Backward + | SkipForward + | SkipBackward + | First + | Last + | Reload + | UnknownCommand String + + +-------------------------------------------------------------------------------- +readPresentationCommand :: IO PresentationCommand +readPresentationCommand = do + k <- readKey + case k of + "q" -> return Exit + "\n" -> return Forward + "\DEL" -> return Backward + "h" -> return Backward + "j" -> return SkipForward + "k" -> return SkipBackward + "l" -> return Forward + -- Arrow keys + "\ESC[C" -> return Forward + "\ESC[D" -> return Backward + "\ESC[B" -> return SkipForward + "\ESC[A" -> return SkipBackward + -- PageUp and PageDown + "\ESC[6" -> return Forward + "\ESC[5" -> return Backward + "0" -> return First + "G" -> return Last + "r" -> return Reload + _ -> return (UnknownCommand k) + where + readKey :: IO String + readKey = do + c0 <- getChar + case c0 of + '\ESC' -> do + c1 <- getChar + case c1 of + '[' -> do + c2 <- getChar + return [c0, c1, c2] + _ -> return [c0, c1] + _ -> return [c0] + + +-------------------------------------------------------------------------------- +data UpdatedPresentation + = UpdatedPresentation !Presentation + | ExitedPresentation + | ErroredPresentation String + deriving (Show) + + +-------------------------------------------------------------------------------- +updatePresentation + :: PresentationCommand -> Presentation -> IO UpdatedPresentation + +updatePresentation cmd presentation = case cmd of + Exit -> return ExitedPresentation + Forward -> return $ goToSlide $ \(s, f) -> (s, f + 1) + Backward -> return $ goToSlide $ \(s, f) -> (s, f - 1) + SkipForward -> return $ goToSlide $ \(s, _) -> (s + 10, 0) + SkipBackward -> return $ goToSlide $ \(s, _) -> (s - 10, 0) + First -> return $ goToSlide $ \_ -> (0, 0) + Last -> return $ goToSlide $ \_ -> (numSlides presentation, 0) + Reload -> reloadPresentation + UnknownCommand _ -> return (UpdatedPresentation presentation) + where + numSlides :: Presentation -> Int + numSlides pres = length (pSlides pres) + + clip :: Index -> Presentation -> Index + clip (slide, fragment) pres + | slide >= numSlides pres = (numSlides pres - 1, lastFragments - 1) + | slide < 0 = (0, 0) + | fragment >= numFragments' slide = + if slide + 1 >= numSlides pres + then (slide, lastFragments - 1) + else (slide + 1, 0) + | fragment < 0 = + if slide - 1 >= 0 + then (slide - 1, numFragments' (slide - 1) - 1) + else (slide, 0) + | otherwise = (slide, fragment) + where + numFragments' s = maybe 1 numFragments (getSlide s pres) + lastFragments = numFragments' (numSlides pres - 1) + + goToSlide :: (Index -> Index) -> UpdatedPresentation + goToSlide f = UpdatedPresentation $ presentation + { pActiveFragment = clip (f $ pActiveFragment presentation) presentation + } + + reloadPresentation = do + errOrPres <- readPresentation (pFilePath presentation) + return $ case errOrPres of + Left err -> ErroredPresentation err + Right pres -> UpdatedPresentation $ pres + { pActiveFragment = clip (pActiveFragment presentation) pres + } diff --git a/src/Patat/Presentation/Internal.hs b/src/Patat/Presentation/Internal.hs new file mode 100644 index 0000000..db8d16b --- /dev/null +++ b/src/Patat/Presentation/Internal.hs @@ -0,0 +1,266 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Patat.Presentation.Internal + ( Presentation (..) + , PresentationSettings (..) + , defaultPresentationSettings + + , Margins (..) + , marginsOf + + , ExtensionList (..) + , defaultExtensionList + + , ImageSettings (..) + + , Slide (..) + , Fragment (..) + , Index + + , getSlide + , numFragments + + , ActiveFragment (..) + , getActiveFragment + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (mplus) +import qualified Data.Aeson.Extended as A +import qualified Data.Aeson.TH.Extended as A +import qualified Data.Foldable as Foldable +import Data.List (intercalate) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import qualified Data.Text as T +import qualified Patat.Theme as Theme +import Prelude +import qualified Text.Pandoc as Pandoc +import Text.Read (readMaybe) + + +-------------------------------------------------------------------------------- +data Presentation = Presentation + { pFilePath :: !FilePath + , pTitle :: ![Pandoc.Inline] + , pAuthor :: ![Pandoc.Inline] + , pSettings :: !PresentationSettings + , pSlides :: [Slide] + , pActiveFragment :: !Index + } deriving (Show) + + +-------------------------------------------------------------------------------- +-- | These are patat-specific settings. That is where they differ from more +-- general metadata (author, title...) +data PresentationSettings = PresentationSettings + { psRows :: !(Maybe (A.FlexibleNum Int)) + , psColumns :: !(Maybe (A.FlexibleNum Int)) + , psMargins :: !(Maybe Margins) + , psWrap :: !(Maybe Bool) + , psTheme :: !(Maybe Theme.Theme) + , psIncrementalLists :: !(Maybe Bool) + , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int)) + , psSlideLevel :: !(Maybe Int) + , psPandocExtensions :: !(Maybe ExtensionList) + , psImages :: !(Maybe ImageSettings) + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Semigroup PresentationSettings where + l <> r = PresentationSettings + { psRows = psRows l `mplus` psRows r + , psColumns = psColumns l `mplus` psColumns r + , psMargins = psMargins l <> psMargins r + , psWrap = psWrap l `mplus` psWrap r + , psTheme = psTheme l <> psTheme r + , psIncrementalLists = psIncrementalLists l `mplus` psIncrementalLists r + , psAutoAdvanceDelay = psAutoAdvanceDelay l `mplus` psAutoAdvanceDelay r + , psSlideLevel = psSlideLevel l `mplus` psSlideLevel r + , psPandocExtensions = psPandocExtensions l `mplus` psPandocExtensions r + , psImages = psImages l `mplus` psImages r + } + + +-------------------------------------------------------------------------------- +instance Monoid PresentationSettings where + mappend = (<>) + mempty = PresentationSettings + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing + + +-------------------------------------------------------------------------------- +defaultPresentationSettings :: PresentationSettings +defaultPresentationSettings = PresentationSettings + { psRows = Nothing + , psColumns = Nothing + , psMargins = Just defaultMargins + , psWrap = Nothing + , psTheme = Just Theme.defaultTheme + , psIncrementalLists = Nothing + , psAutoAdvanceDelay = Nothing + , psSlideLevel = Nothing + , psPandocExtensions = Nothing + , psImages = Nothing + } + + +-------------------------------------------------------------------------------- +data Margins = Margins + { mLeft :: !(Maybe (A.FlexibleNum Int)) + , mRight :: !(Maybe (A.FlexibleNum Int)) + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Semigroup Margins where + l <> r = Margins + { mLeft = mLeft l `mplus` mLeft r + , mRight = mRight l `mplus` mRight r + } + + +-------------------------------------------------------------------------------- +instance Monoid Margins where + mappend = (<>) + mempty = Margins Nothing Nothing + + +-------------------------------------------------------------------------------- +defaultMargins :: Margins +defaultMargins = Margins + { mLeft = Nothing + , mRight = Nothing + } + + +-------------------------------------------------------------------------------- +marginsOf :: PresentationSettings -> (Int, Int) +marginsOf presentationSettings = + (marginLeft, marginRight) + where + margins = fromMaybe defaultMargins $ psMargins presentationSettings + marginLeft = fromMaybe 0 (A.unFlexibleNum <$> mLeft margins) + marginRight = fromMaybe 0 (A.unFlexibleNum <$> mRight margins) + + +-------------------------------------------------------------------------------- +newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions} + deriving (Show) + + +-------------------------------------------------------------------------------- +instance A.FromJSON ExtensionList where + parseJSON = A.withArray "FromJSON ExtensionList" $ + fmap (ExtensionList . mconcat) . mapM parseExt . Foldable.toList + where + parseExt = A.withText "FromJSON ExtensionList" $ \txt -> case txt of + -- Our default extensions + "patat_extensions" -> return (unExtensionList defaultExtensionList) + + -- Individuals + _ -> case readMaybe ("Ext_" ++ T.unpack txt) of + Just e -> return $ Pandoc.extensionsFromList [e] + Nothing -> fail $ + "Unknown extension: " ++ show txt ++ + ", known extensions are: " ++ + intercalate ", " + [ show (drop 4 (show e)) + | e <- [minBound .. maxBound] :: [Pandoc.Extension] + ] + + +-------------------------------------------------------------------------------- +defaultExtensionList :: ExtensionList +defaultExtensionList = ExtensionList $ + Pandoc.readerExtensions Pandoc.def `mappend` Pandoc.extensionsFromList + [ Pandoc.Ext_yaml_metadata_block + , Pandoc.Ext_table_captions + , Pandoc.Ext_simple_tables + , Pandoc.Ext_multiline_tables + , Pandoc.Ext_grid_tables + , Pandoc.Ext_pipe_tables + , Pandoc.Ext_raw_html + , Pandoc.Ext_tex_math_dollars + , Pandoc.Ext_fenced_code_blocks + , Pandoc.Ext_fenced_code_attributes + , Pandoc.Ext_backtick_code_blocks + , Pandoc.Ext_inline_code_attributes + , Pandoc.Ext_fancy_lists + , Pandoc.Ext_four_space_rule + , Pandoc.Ext_definition_lists + , Pandoc.Ext_compact_definition_lists + , Pandoc.Ext_example_lists + , Pandoc.Ext_strikeout + , Pandoc.Ext_superscript + , Pandoc.Ext_subscript + ] + + +-------------------------------------------------------------------------------- +data ImageSettings = ImageSettings + { isBackend :: !T.Text + , isParams :: !A.Object + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance A.FromJSON ImageSettings where + parseJSON = A.withObject "FromJSON ImageSettings" $ \o -> do + t <- o A..: "backend" + return ImageSettings {isBackend = t, isParams = o} + + +-------------------------------------------------------------------------------- +data Slide + = ContentSlide [Fragment] + | TitleSlide Pandoc.Block + deriving (Show) + + +-------------------------------------------------------------------------------- +newtype Fragment = Fragment {unFragment :: [Pandoc.Block]} + deriving (Monoid, Semigroup, Show) + + +-------------------------------------------------------------------------------- +-- | Active slide, active fragment. +type Index = (Int, Int) + + +-------------------------------------------------------------------------------- +getSlide :: Int -> Presentation -> Maybe Slide +getSlide sidx = listToMaybe . drop sidx . pSlides + + +-------------------------------------------------------------------------------- +numFragments :: Slide -> Int +numFragments (ContentSlide fragments) = length fragments +numFragments (TitleSlide _) = 1 + + +-------------------------------------------------------------------------------- +data ActiveFragment = ActiveContent Fragment | ActiveTitle Pandoc.Block + deriving (Show) + + +-------------------------------------------------------------------------------- +getActiveFragment :: Presentation -> Maybe ActiveFragment +getActiveFragment presentation = do + let (sidx, fidx) = pActiveFragment presentation + slide <- getSlide sidx presentation + case slide of + TitleSlide block -> return (ActiveTitle block) + ContentSlide fragments -> + fmap ActiveContent . listToMaybe $ drop fidx fragments + + +-------------------------------------------------------------------------------- +$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings) +$(A.deriveFromJSON A.dropPrefixOptions ''Margins) diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs new file mode 100644 index 0000000..581c31d --- /dev/null +++ b/src/Patat/Presentation/Read.hs @@ -0,0 +1,205 @@ +-- | Read a presentation from disk. +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Read + ( readPresentation + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad.Except (ExceptT (..), runExceptT, + throwError) +import Control.Monad.Trans (liftIO) +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HMS +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty, (<>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Yaml as Yaml +import Patat.Presentation.Fragment +import Patat.Presentation.Internal +import Prelude +import System.Directory (doesFileExist, getHomeDirectory) +import System.FilePath (takeExtension, ()) +import qualified Text.Pandoc.Error as Pandoc +import qualified Text.Pandoc.Extended as Pandoc + + +-------------------------------------------------------------------------------- +readPresentation :: FilePath -> IO (Either String Presentation) +readPresentation filePath = runExceptT $ do + -- We need to read the settings first. + src <- liftIO $ T.readFile filePath + homeSettings <- ExceptT readHomeSettings + metaSettings <- ExceptT $ return $ readMetaSettings src + let settings = metaSettings <> homeSettings <> defaultPresentationSettings + + let pexts = fromMaybe defaultExtensionList (psPandocExtensions settings) + reader <- case readExtension pexts ext of + Nothing -> throwError $ "Unknown file extension: " ++ show ext + Just x -> return x + doc <- case reader src of + Left e -> throwError $ "Could not parse document: " ++ show e + Right x -> return x + + ExceptT $ return $ pandocToPresentation filePath settings doc + where + ext = takeExtension filePath + + +-------------------------------------------------------------------------------- +readExtension + :: ExtensionList -> String + -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc) +readExtension (ExtensionList extensions) fileExt = case fileExt of + ".md" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".lhs" -> Just $ Pandoc.runPure . Pandoc.readMarkdown lhsOpts + "" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".org" -> Just $ Pandoc.runPure . Pandoc.readOrg readerOpts + _ -> Nothing + + where + readerOpts = Pandoc.def + { Pandoc.readerExtensions = + extensions <> absolutelyRequiredExtensions + } + + lhsOpts = readerOpts + { Pandoc.readerExtensions = + Pandoc.readerExtensions readerOpts <> + Pandoc.extensionsFromList [Pandoc.Ext_literate_haskell] + } + + absolutelyRequiredExtensions = + Pandoc.extensionsFromList [Pandoc.Ext_yaml_metadata_block] + + +-------------------------------------------------------------------------------- +pandocToPresentation + :: FilePath -> PresentationSettings -> Pandoc.Pandoc + -> Either String Presentation +pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do + let !pTitle = Pandoc.docTitle meta + !pSlides = pandocToSlides pSettings pandoc + !pActiveFragment = (0, 0) + !pAuthor = concat (Pandoc.docAuthors meta) + return Presentation {..} + + +-------------------------------------------------------------------------------- +-- | This re-parses the pandoc metadata block using the YAML library. This +-- avoids the problems caused by pandoc involving rendering Markdown. This +-- should only be used for settings though, not things like title / authors +-- since those /can/ contain markdown. +parseMetadataBlock :: T.Text -> Maybe A.Value +parseMetadataBlock src = do + block <- T.encodeUtf8 <$> mbBlock + either (const Nothing) Just (Yaml.decodeEither' block) + where + mbBlock :: Maybe T.Text + mbBlock = case T.lines src of + ("---" : ls) -> case break (`elem` ["---", "..."]) ls of + (_, []) -> Nothing + (block, (_ : _)) -> Just (T.unlines block) + _ -> Nothing + + +-------------------------------------------------------------------------------- +-- | Read settings from the metadata block in the Pandoc document. +readMetaSettings :: T.Text -> Either String PresentationSettings +readMetaSettings src = fromMaybe (Right mempty) $ do + A.Object obj <- parseMetadataBlock src + val <- HMS.lookup "patat" obj + return $! resultToEither $! A.fromJSON val + where + resultToEither :: A.Result a -> Either String a + resultToEither (A.Success x) = Right x + resultToEither (A.Error e) = Left $! + "Error parsing patat settings from metadata: " ++ e + + +-------------------------------------------------------------------------------- +-- | Read settings from "$HOME/.patat.yaml". +readHomeSettings :: IO (Either String PresentationSettings) +readHomeSettings = do + home <- getHomeDirectory + let path = home ".patat.yaml" + exists <- doesFileExist path + if not exists + then return (Right mempty) + else do + errOrPs <- Yaml.decodeFileEither path + return $! case errOrPs of + Left err -> Left (show err) + Right ps -> Right ps + + +-------------------------------------------------------------------------------- +pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> [Slide] +pandocToSlides settings pandoc = + let slideLevel = fromMaybe (detectSlideLevel pandoc) (psSlideLevel settings) + unfragmented = splitSlides slideLevel pandoc + fragmented = + [ case slide of + TitleSlide _ -> slide + ContentSlide fragments0 -> + let blocks = concatMap unFragment fragments0 + blockss = fragmentBlocks fragmentSettings blocks in + ContentSlide (map Fragment blockss) + | slide <- unfragmented + ] in + fragmented + where + fragmentSettings = FragmentSettings + { fsIncrementalLists = fromMaybe False (psIncrementalLists settings) + } + + +-------------------------------------------------------------------------------- +-- | Find level of header that starts slides. This is defined as the least +-- header that occurs before a non-header in the blocks. +detectSlideLevel :: Pandoc.Pandoc -> Int +detectSlideLevel (Pandoc.Pandoc _meta blocks0) = + go 6 blocks0 + where + go level (Pandoc.Header n _ _ : x : xs) + | n < level && nonHeader x = go n xs + | otherwise = go level (x:xs) + go level (_ : xs) = go level xs + go level [] = level + + nonHeader (Pandoc.Header _ _ _) = False + nonHeader _ = True + + +-------------------------------------------------------------------------------- +-- | Split a pandoc document into slides. If the document contains horizonal +-- rules, we use those as slide delimiters. If there are no horizontal rules, +-- we split using headers, determined by the slide level (see +-- 'detectSlideLevel'). +splitSlides :: Int -> Pandoc.Pandoc -> [Slide] +splitSlides slideLevel (Pandoc.Pandoc _meta blocks0) + | any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0 + | otherwise = splitAtHeaders [] blocks0 + where + mkContentSlide :: [Pandoc.Block] -> [Slide] + mkContentSlide [] = [] -- Never create empty slides + mkContentSlide bs = [ContentSlide [Fragment bs]] + + splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of + (xs, []) -> mkContentSlide xs + (xs, (_rule : ys)) -> mkContentSlide xs ++ splitAtRules ys + + splitAtHeaders acc [] = + mkContentSlide (reverse acc) + splitAtHeaders acc (b@(Pandoc.Header i _ _) : bs) + | i > slideLevel = splitAtHeaders (b : acc) bs + | i == slideLevel = + mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs + | otherwise = + mkContentSlide (reverse acc) ++ [TitleSlide b] ++ splitAtHeaders [] bs + splitAtHeaders acc (b : bs) = + splitAtHeaders (b : acc) bs diff --git a/src/Patat/PrettyPrint.hs b/src/Patat/PrettyPrint.hs new file mode 100644 index 0000000..bffa274 --- /dev/null +++ b/src/Patat/PrettyPrint.hs @@ -0,0 +1,411 @@ +-------------------------------------------------------------------------------- +-- | This is a small pretty-printing library. +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.PrettyPrint + ( Doc + , toString + , dimensions + , null + + , hPutDoc + , putDoc + + , string + , text + , space + , spaces + , softline + , hardline + + , wrapAt + + , Trimmable (..) + , indent + + , ansi + + , (<+>) + , (<$$>) + , vcat + + -- * Exotic combinators + , Alignment (..) + , align + , paste + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad.Reader (asks, local) +import Control.Monad.RWS (RWS, runRWS) +import Control.Monad.State (get, gets, modify) +import Control.Monad.Writer (tell) +import Data.Foldable (Foldable) +import qualified Data.List as L +import Data.Monoid (Monoid, mconcat, mempty) +import Data.Semigroup (Semigroup (..)) +import Data.String (IsString (..)) +import qualified Data.Text as T +import Data.Traversable (Traversable, traverse) +import Prelude hiding (null) +import qualified System.Console.ANSI as Ansi +import qualified System.IO as IO + + +-------------------------------------------------------------------------------- +-- | A simple chunk of text. All ANSI codes are "reset" after printing. +data Chunk + = StringChunk [Ansi.SGR] String + | NewlineChunk + deriving (Eq) + + +-------------------------------------------------------------------------------- +type Chunks = [Chunk] + + +-------------------------------------------------------------------------------- +hPutChunk :: IO.Handle -> Chunk -> IO () +hPutChunk h NewlineChunk = IO.hPutStrLn h "" +hPutChunk h (StringChunk codes str) = do + Ansi.hSetSGR h (reverse codes) + IO.hPutStr h str + Ansi.hSetSGR h [Ansi.Reset] + + +-------------------------------------------------------------------------------- +chunkToString :: Chunk -> String +chunkToString NewlineChunk = "\n" +chunkToString (StringChunk _ str) = str + + +-------------------------------------------------------------------------------- +-- | If two neighboring chunks have the same set of ANSI codes, we can group +-- them together. +optimizeChunks :: Chunks -> Chunks +optimizeChunks (StringChunk c1 s1 : StringChunk c2 s2 : chunks) + | c1 == c2 = optimizeChunks (StringChunk c1 (s1 <> s2) : chunks) + | otherwise = + StringChunk c1 s1 : optimizeChunks (StringChunk c2 s2 : chunks) +optimizeChunks (x : chunks) = x : optimizeChunks chunks +optimizeChunks [] = [] + + +-------------------------------------------------------------------------------- +chunkLines :: Chunks -> [Chunks] +chunkLines chunks = case break (== NewlineChunk) chunks of + (xs, _newline : ys) -> xs : chunkLines ys + (xs, []) -> [xs] + + +-------------------------------------------------------------------------------- +data DocE + = String String + | Softspace + | Hardspace + | Softline + | Hardline + | WrapAt + { wrapAtCol :: Maybe Int + , wrapDoc :: Doc + } + | Ansi + { ansiCode :: [Ansi.SGR] -> [Ansi.SGR] -- ^ Modifies current codes. + , ansiDoc :: Doc + } + | Indent + { indentFirstLine :: LineBuffer + , indentOtherLines :: LineBuffer + , indentDoc :: Doc + } + + +-------------------------------------------------------------------------------- +chunkToDocE :: Chunk -> DocE +chunkToDocE NewlineChunk = Hardline +chunkToDocE (StringChunk codes str) = Ansi (\_ -> codes) (Doc [String str]) + + +-------------------------------------------------------------------------------- +newtype Doc = Doc {unDoc :: [DocE]} + deriving (Monoid, Semigroup) + + +-------------------------------------------------------------------------------- +instance IsString Doc where + fromString = string + + +-------------------------------------------------------------------------------- +instance Show Doc where + show = toString + + +-------------------------------------------------------------------------------- +data DocEnv = DocEnv + { deCodes :: [Ansi.SGR] -- ^ Most recent ones first in the list + , deIndent :: LineBuffer -- ^ Don't need to store first-line indent + , deWrap :: Maybe Int -- ^ Wrap at columns + } + + +-------------------------------------------------------------------------------- +type DocM = RWS DocEnv Chunks LineBuffer + + +-------------------------------------------------------------------------------- +data Trimmable a + = NotTrimmable !a + | Trimmable !a + deriving (Foldable, Functor, Traversable) + + +-------------------------------------------------------------------------------- +-- | Note that this is reversed so we have fast append +type LineBuffer = [Trimmable Chunk] + + +-------------------------------------------------------------------------------- +bufferToChunks :: LineBuffer -> Chunks +bufferToChunks = map trimmableToChunk . reverse . dropWhile isTrimmable + where + isTrimmable (NotTrimmable _) = False + isTrimmable (Trimmable _) = True + + trimmableToChunk (NotTrimmable c) = c + trimmableToChunk (Trimmable c) = c + + +-------------------------------------------------------------------------------- +docToChunks :: Doc -> Chunks +docToChunks doc0 = + let env0 = DocEnv [] [] Nothing + ((), b, cs) = runRWS (go $ unDoc doc0) env0 mempty in + optimizeChunks (cs <> bufferToChunks b) + where + go :: [DocE] -> DocM () + + go [] = return () + + go (String str : docs) = do + chunk <- makeChunk str + modify (NotTrimmable chunk :) + go docs + + go (Softspace : docs) = do + hard <- softConversion Softspace docs + go (hard : docs) + + go (Hardspace : docs) = do + chunk <- makeChunk " " + modify (NotTrimmable chunk :) + go docs + + go (Softline : docs) = do + hard <- softConversion Softline docs + go (hard : docs) + + go (Hardline : docs) = do + buffer <- get + tell $ bufferToChunks buffer <> [NewlineChunk] + indentation <- asks deIndent + modify $ \_ -> if L.null docs then [] else indentation + go docs + + go (WrapAt {..} : docs) = do + local (\env -> env {deWrap = wrapAtCol}) $ go (unDoc wrapDoc) + go docs + + go (Ansi {..} : docs) = do + local (\env -> env {deCodes = ansiCode (deCodes env)}) $ + go (unDoc ansiDoc) + go docs + + go (Indent {..} : docs) = do + local (\env -> env {deIndent = indentOtherLines ++ deIndent env}) $ do + modify (indentFirstLine ++) + go (unDoc indentDoc) + go docs + + makeChunk :: String -> DocM Chunk + makeChunk str = do + codes <- asks deCodes + return $ StringChunk codes str + + -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline' + softConversion :: DocE -> [DocE] -> DocM DocE + softConversion soft docs = do + mbWrapCol <- asks deWrap + case mbWrapCol of + Nothing -> return hard + Just maxCol -> do + -- Slow. + currentLine <- gets (concatMap chunkToString . bufferToChunks) + let currentCol = length currentLine + case nextWordLength docs of + Nothing -> return hard + Just l + | currentCol + 1 + l <= maxCol -> return Hardspace + | otherwise -> return Hardline + where + hard = case soft of + Softspace -> Hardspace + Softline -> Hardline + _ -> soft + + nextWordLength :: [DocE] -> Maybe Int + nextWordLength [] = Nothing + nextWordLength (String x : xs) + | L.null x = nextWordLength xs + | otherwise = Just (length x) + nextWordLength (Softspace : xs) = nextWordLength xs + nextWordLength (Hardspace : xs) = nextWordLength xs + nextWordLength (Softline : xs) = nextWordLength xs + nextWordLength (Hardline : _) = Nothing + nextWordLength (WrapAt {..} : xs) = nextWordLength (unDoc wrapDoc ++ xs) + nextWordLength (Ansi {..} : xs) = nextWordLength (unDoc ansiDoc ++ xs) + nextWordLength (Indent {..} : xs) = nextWordLength (unDoc indentDoc ++ xs) + + +-------------------------------------------------------------------------------- +toString :: Doc -> String +toString = concat . map chunkToString . docToChunks + + +-------------------------------------------------------------------------------- +-- | Returns the rows and columns necessary to render this document +dimensions :: Doc -> (Int, Int) +dimensions doc = + let ls = lines (toString doc) in + (length ls, foldr max 0 (map length ls)) + + +-------------------------------------------------------------------------------- +null :: Doc -> Bool +null doc = case unDoc doc of [] -> True; _ -> False + + +-------------------------------------------------------------------------------- +hPutDoc :: IO.Handle -> Doc -> IO () +hPutDoc h = mapM_ (hPutChunk h) . docToChunks + + +-------------------------------------------------------------------------------- +putDoc :: Doc -> IO () +putDoc = hPutDoc IO.stdout + + +-------------------------------------------------------------------------------- +mkDoc :: DocE -> Doc +mkDoc e = Doc [e] + + +-------------------------------------------------------------------------------- +string :: String -> Doc +string = mkDoc . String -- TODO (jaspervdj): Newline conversion + + +-------------------------------------------------------------------------------- +text :: T.Text -> Doc +text = string . T.unpack + + +-------------------------------------------------------------------------------- +space :: Doc +space = mkDoc Softspace + + +-------------------------------------------------------------------------------- +spaces :: Int -> Doc +spaces n = mconcat $ replicate n space + + +-------------------------------------------------------------------------------- +softline :: Doc +softline = mkDoc Softline + + +-------------------------------------------------------------------------------- +hardline :: Doc +hardline = mkDoc Hardline + + +-------------------------------------------------------------------------------- +wrapAt :: Maybe Int -> Doc -> Doc +wrapAt wrapAtCol wrapDoc = mkDoc WrapAt {..} + + +-------------------------------------------------------------------------------- +indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc +indent firstLineDoc otherLinesDoc doc = mkDoc $ Indent + { indentFirstLine = traverse docToChunks firstLineDoc + , indentOtherLines = traverse docToChunks otherLinesDoc + , indentDoc = doc + } + + +-------------------------------------------------------------------------------- +ansi :: [Ansi.SGR] -> Doc -> Doc +ansi codes = mkDoc . Ansi (codes ++) + + +-------------------------------------------------------------------------------- +(<+>) :: Doc -> Doc -> Doc +x <+> y = x <> space <> y +infixr 6 <+> + + +-------------------------------------------------------------------------------- +(<$$>) :: Doc -> Doc -> Doc +x <$$> y = x <> hardline <> y +infixr 5 <$$> + + +-------------------------------------------------------------------------------- +vcat :: [Doc] -> Doc +vcat = mconcat . L.intersperse hardline + + +-------------------------------------------------------------------------------- +data Alignment = AlignLeft | AlignCenter | AlignRight deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- +align :: Int -> Alignment -> Doc -> Doc +align width alignment doc0 = + let chunks0 = docToChunks doc0 + lines_ = chunkLines chunks0 in + vcat + [ Doc (map chunkToDocE (alignLine line)) + | line <- lines_ + ] + where + lineWidth :: [Chunk] -> Int + lineWidth = sum . map (length . chunkToString) + + alignLine :: [Chunk] -> [Chunk] + alignLine line = + let actual = lineWidth line + chunkSpaces n = [StringChunk [] (replicate n ' ')] in + case alignment of + AlignLeft -> line <> chunkSpaces (width - actual) + AlignRight -> chunkSpaces (width - actual) <> line + AlignCenter -> + let r = (width - actual) `div` 2 + l = (width - actual) - r in + chunkSpaces l <> line <> chunkSpaces r + + +-------------------------------------------------------------------------------- +-- | Like the unix program 'paste'. +paste :: [Doc] -> Doc +paste docs0 = + let chunkss = map docToChunks docs0 :: [Chunks] + cols = map chunkLines chunkss :: [[Chunks]] + rows0 = L.transpose cols :: [[Chunks]] + rows1 = map (map (Doc . map chunkToDocE)) rows0 :: [[Doc]] in + vcat $ map mconcat rows1 diff --git a/src/Patat/Theme.hs b/src/Patat/Theme.hs new file mode 100644 index 0000000..952a521 --- /dev/null +++ b/src/Patat/Theme.hs @@ -0,0 +1,324 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Patat.Theme + ( Theme (..) + , defaultTheme + + , Style (..) + + , SyntaxHighlighting (..) + , defaultSyntaxHighlighting + , syntaxHighlight + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (forM_, mplus) +import qualified Data.Aeson as A +import qualified Data.Aeson.TH.Extended as A +import Data.Char (toLower, toUpper) +import Data.Colour.SRGB (RGB(..), sRGB24reads, toSRGB24) +import Data.List (intercalate, isPrefixOf, isSuffixOf) +import qualified Data.Map as M +import Data.Maybe (mapMaybe, maybeToList) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import qualified Data.Text as T +import Numeric (showHex) +import Prelude +import qualified Skylighting as Skylighting +import qualified System.Console.ANSI as Ansi +import Text.Read (readMaybe) + + +-------------------------------------------------------------------------------- +data Theme = Theme + { themeBorders :: !(Maybe Style) + , themeHeader :: !(Maybe Style) + , themeCodeBlock :: !(Maybe Style) + , themeBulletList :: !(Maybe Style) + , themeBulletListMarkers :: !(Maybe T.Text) + , themeOrderedList :: !(Maybe Style) + , themeBlockQuote :: !(Maybe Style) + , themeDefinitionTerm :: !(Maybe Style) + , themeDefinitionList :: !(Maybe Style) + , themeTableHeader :: !(Maybe Style) + , themeTableSeparator :: !(Maybe Style) + , themeLineBlock :: !(Maybe Style) + , themeEmph :: !(Maybe Style) + , themeStrong :: !(Maybe Style) + , themeCode :: !(Maybe Style) + , themeLinkText :: !(Maybe Style) + , themeLinkTarget :: !(Maybe Style) + , themeStrikeout :: !(Maybe Style) + , themeQuoted :: !(Maybe Style) + , themeMath :: !(Maybe Style) + , themeImageText :: !(Maybe Style) + , themeImageTarget :: !(Maybe Style) + , themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting) + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Semigroup Theme where + l <> r = Theme + { themeBorders = mplusOn themeBorders + , themeHeader = mplusOn themeHeader + , themeCodeBlock = mplusOn themeCodeBlock + , themeBulletList = mplusOn themeBulletList + , themeBulletListMarkers = mplusOn themeBulletListMarkers + , themeOrderedList = mplusOn themeOrderedList + , themeBlockQuote = mplusOn themeBlockQuote + , themeDefinitionTerm = mplusOn themeDefinitionTerm + , themeDefinitionList = mplusOn themeDefinitionList + , themeTableHeader = mplusOn themeTableHeader + , themeTableSeparator = mplusOn themeTableSeparator + , themeLineBlock = mplusOn themeLineBlock + , themeEmph = mplusOn themeEmph + , themeStrong = mplusOn themeStrong + , themeCode = mplusOn themeCode + , themeLinkText = mplusOn themeLinkText + , themeLinkTarget = mplusOn themeLinkTarget + , themeStrikeout = mplusOn themeStrikeout + , themeQuoted = mplusOn themeQuoted + , themeMath = mplusOn themeMath + , themeImageText = mplusOn themeImageText + , themeImageTarget = mplusOn themeImageTarget + , themeSyntaxHighlighting = mappendOn themeSyntaxHighlighting + } + where + mplusOn f = f l `mplus` f r + mappendOn f = f l `mappend` f r + + +-------------------------------------------------------------------------------- +instance Monoid Theme where + mappend = (<>) + mempty = Theme + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + +-------------------------------------------------------------------------------- +defaultTheme :: Theme +defaultTheme = Theme + { themeBorders = dull Ansi.Yellow + , themeHeader = dull Ansi.Blue + , themeCodeBlock = dull Ansi.White `mappend` ondull Ansi.Black + , themeBulletList = dull Ansi.Magenta + , themeBulletListMarkers = Just "-*" + , themeOrderedList = dull Ansi.Magenta + , themeBlockQuote = dull Ansi.Green + , themeDefinitionTerm = dull Ansi.Blue + , themeDefinitionList = dull Ansi.Magenta + , themeTableHeader = dull Ansi.Blue + , themeTableSeparator = dull Ansi.Magenta + , themeLineBlock = dull Ansi.Magenta + , themeEmph = dull Ansi.Green + , themeStrong = dull Ansi.Red `mappend` bold + , themeCode = dull Ansi.White `mappend` ondull Ansi.Black + , themeLinkText = dull Ansi.Green + , themeLinkTarget = dull Ansi.Cyan `mappend` underline + , themeStrikeout = ondull Ansi.Red + , themeQuoted = dull Ansi.Green + , themeMath = dull Ansi.Green + , themeImageText = dull Ansi.Green + , themeImageTarget = dull Ansi.Cyan `mappend` underline + , themeSyntaxHighlighting = Just defaultSyntaxHighlighting + } + where + dull c = Just $ Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c] + ondull c = Just $ Style [Ansi.SetColor Ansi.Background Ansi.Dull c] + bold = Just $ Style [Ansi.SetConsoleIntensity Ansi.BoldIntensity] + underline = Just $ Style [Ansi.SetUnderlining Ansi.SingleUnderline] + + +-------------------------------------------------------------------------------- +newtype Style = Style {unStyle :: [Ansi.SGR]} + deriving (Monoid, Semigroup, Show) + + +-------------------------------------------------------------------------------- +instance A.ToJSON Style where + toJSON = A.toJSON . mapMaybe sgrToString . unStyle + + +-------------------------------------------------------------------------------- +instance A.FromJSON Style where + parseJSON val = do + names <- A.parseJSON val + sgrs <- mapM toSgr names + return $! Style sgrs + where + toSgr name = case stringToSgr name of + Just sgr -> return sgr + Nothing -> fail $! + "Unknown style: " ++ show name ++ ". Known styles are: " ++ + intercalate ", " (map show $ M.keys namedSgrs) ++ + ", or \"rgb#RrGgBb\" and \"onRgb#RrGgBb\" where 'Rr', " ++ + "'Gg' and 'Bb' are hexadecimal bytes (e.g. \"rgb#f08000\")." + + +-------------------------------------------------------------------------------- +stringToSgr :: String -> Maybe Ansi.SGR +stringToSgr s + | "rgb#" `isPrefixOf` s = rgbToSgr Ansi.Foreground $ drop 4 s + | "onRgb#" `isPrefixOf` s = rgbToSgr Ansi.Background $ drop 6 s + | otherwise = M.lookup s namedSgrs + + +-------------------------------------------------------------------------------- +rgbToSgr :: Ansi.ConsoleLayer -> String -> Maybe Ansi.SGR +rgbToSgr layer rgbHex = + case sRGB24reads rgbHex of + [(color, "")] -> Just $ Ansi.SetRGBColor layer color + _ -> Nothing + + +-------------------------------------------------------------------------------- +sgrToString :: Ansi.SGR -> Maybe String +sgrToString (Ansi.SetColor layer intensity color) = Just $ + (\str -> case layer of + Ansi.Foreground -> str + Ansi.Background -> "on" ++ capitalize str) $ + (case intensity of + Ansi.Dull -> "dull" + Ansi.Vivid -> "vivid") ++ + (case color of + Ansi.Black -> "Black" + Ansi.Red -> "Red" + Ansi.Green -> "Green" + Ansi.Yellow -> "Yellow" + Ansi.Blue -> "Blue" + Ansi.Magenta -> "Magenta" + Ansi.Cyan -> "Cyan" + Ansi.White -> "White") + +sgrToString (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline" + +sgrToString (Ansi.SetConsoleIntensity Ansi.BoldIntensity) = Just "bold" + +sgrToString (Ansi.SetItalicized True) = Just "italic" + +sgrToString (Ansi.SetRGBColor layer color) = Just $ + (\str -> case layer of + Ansi.Foreground -> str + Ansi.Background -> "on" ++ capitalize str) $ + "rgb#" ++ (toRGBHex $ toSRGB24 color) + where + toRGBHex (RGB r g b) = concat $ map toHexByte [r, g, b] + toHexByte x = showHex2 x "" + showHex2 x | x <= 0xf = ("0" ++) . showHex x + | otherwise = showHex x + +sgrToString _ = Nothing + + +-------------------------------------------------------------------------------- +namedSgrs :: M.Map String Ansi.SGR +namedSgrs = M.fromList + [ (name, sgr) + | sgr <- knownSgrs + , name <- maybeToList (sgrToString sgr) + ] + where + -- | It doesn't really matter if we generate "too much" SGRs here since + -- 'sgrToString' will only pick the ones we support. + knownSgrs = + [ Ansi.SetColor l i c + | l <- [minBound .. maxBound] + , i <- [minBound .. maxBound] + , c <- [minBound .. maxBound] + ] ++ + [Ansi.SetUnderlining u | u <- [minBound .. maxBound]] ++ + [Ansi.SetConsoleIntensity c | c <- [minBound .. maxBound]] ++ + [Ansi.SetItalicized i | i <- [minBound .. maxBound]] + + +-------------------------------------------------------------------------------- +newtype SyntaxHighlighting = SyntaxHighlighting + { unSyntaxHighlighting :: M.Map String Style + } deriving (Monoid, Semigroup, Show, A.ToJSON) + + +-------------------------------------------------------------------------------- +instance A.FromJSON SyntaxHighlighting where + parseJSON val = do + styleMap <- A.parseJSON val + forM_ (M.keys styleMap) $ \k -> case nameToTokenType k of + Just _ -> return () + Nothing -> fail $ "Unknown token type: " ++ show k + return (SyntaxHighlighting styleMap) + + +-------------------------------------------------------------------------------- +defaultSyntaxHighlighting :: SyntaxHighlighting +defaultSyntaxHighlighting = mkSyntaxHighlighting + [ (Skylighting.KeywordTok, dull Ansi.Yellow) + , (Skylighting.ControlFlowTok, dull Ansi.Yellow) + + , (Skylighting.DataTypeTok, dull Ansi.Green) + + , (Skylighting.DecValTok, dull Ansi.Red) + , (Skylighting.BaseNTok, dull Ansi.Red) + , (Skylighting.FloatTok, dull Ansi.Red) + , (Skylighting.ConstantTok, dull Ansi.Red) + , (Skylighting.CharTok, dull Ansi.Red) + , (Skylighting.SpecialCharTok, dull Ansi.Red) + , (Skylighting.StringTok, dull Ansi.Red) + , (Skylighting.VerbatimStringTok, dull Ansi.Red) + , (Skylighting.SpecialStringTok, dull Ansi.Red) + + , (Skylighting.CommentTok, dull Ansi.Blue) + , (Skylighting.DocumentationTok, dull Ansi.Blue) + , (Skylighting.AnnotationTok, dull Ansi.Blue) + , (Skylighting.CommentVarTok, dull Ansi.Blue) + + , (Skylighting.ImportTok, dull Ansi.Cyan) + , (Skylighting.OperatorTok, dull Ansi.Cyan) + , (Skylighting.FunctionTok, dull Ansi.Cyan) + , (Skylighting.PreprocessorTok, dull Ansi.Cyan) + ] + where + dull c = Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c] + + mkSyntaxHighlighting ls = SyntaxHighlighting $ + M.fromList [(nameForTokenType tt, s) | (tt, s) <- ls] + + +-------------------------------------------------------------------------------- +nameForTokenType :: Skylighting.TokenType -> String +nameForTokenType = + unCapitalize . dropTok . show + where + unCapitalize (x : xs) = toLower x : xs + unCapitalize xs = xs + + dropTok :: String -> String + dropTok str + | "Tok" `isSuffixOf` str = take (length str - 3) str + | otherwise = str + + +-------------------------------------------------------------------------------- +nameToTokenType :: String -> Maybe Skylighting.TokenType +nameToTokenType = readMaybe . capitalize . (++ "Tok") + + +-------------------------------------------------------------------------------- +capitalize :: String -> String +capitalize "" = "" +capitalize (x : xs) = toUpper x : xs + + +-------------------------------------------------------------------------------- +syntaxHighlight :: Theme -> Skylighting.TokenType -> Maybe Style +syntaxHighlight theme tokenType = do + sh <- themeSyntaxHighlighting theme + M.lookup (nameForTokenType tokenType) (unSyntaxHighlighting sh) + + +-------------------------------------------------------------------------------- +$(A.deriveJSON A.dropPrefixOptions ''Theme) diff --git a/src/Text/Pandoc/Extended.hs b/src/Text/Pandoc/Extended.hs new file mode 100644 index 0000000..941d716 --- /dev/null +++ b/src/Text/Pandoc/Extended.hs @@ -0,0 +1,30 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +module Text.Pandoc.Extended + ( module Text.Pandoc + + , plainToPara + , newlineToSpace + ) where + + +-------------------------------------------------------------------------------- +import Data.Data.Extended (grecT) +import Text.Pandoc +import Prelude + + +-------------------------------------------------------------------------------- +plainToPara :: [Block] -> [Block] +plainToPara = map $ \case + Plain inlines -> Para inlines + block -> block + + +-------------------------------------------------------------------------------- +newlineToSpace :: [Inline] -> [Inline] +newlineToSpace = grecT $ \case + SoftBreak -> Space + LineBreak -> Space + inline -> inline diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..8cbd382 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,15 @@ +resolver: 'lts-13.0' +save-hackage-creds: false + +packages: +- '.' + +flags: + patat: + patat-make-man: true + +extra-deps: +- 'pandoc-2.6' +- 'ipynb-0.1' +- 'ansi-terminal-0.9' +- 'ansi-wl-pprint-0.6.8.2@rev:1' diff --git a/test.sh b/test.sh new file mode 100755 index 0000000..bbe7c5a --- /dev/null +++ b/test.sh @@ -0,0 +1,30 @@ +#!/bin/bash +set -o nounset -o errexit -o pipefail + +srcs=$(find tests -type f ! -name '*.dump') +stuff_went_wrong=false + +for src in $srcs; do + expected="$src.dump" + echo -n "Testing $src... " + actual=$(mktemp) + HOME=/dev/null patat --dump --force "$src" >"$actual" + + if [[ $@ == "--fix" ]]; then + cp "$actual" "$expected" + echo 'Fixed' + elif [[ ! -f "$expected" ]]; then + echo "missing file: $expected" + stuff_went_wrong=true + elif [[ "$(cat "$expected")" == "$(cat "$actual")" ]]; then + echo 'OK' + else + echo 'files differ' + diff "$actual" "$expected" || true + stuff_went_wrong=true + fi +done + +if [[ "$stuff_went_wrong" = true ]]; then + exit 1 +fi diff --git a/tests/01.md b/tests/01.md new file mode 100644 index 0000000..2fbdde2 --- /dev/null +++ b/tests/01.md @@ -0,0 +1,14 @@ +--- +title: This is my presentation +author: Jasper Van der Jeugt +... + +# This is a test + +Hello world + +--- + +# This is a second slide + +lololol diff --git a/tests/01.md.dump b/tests/01.md.dump new file mode 100644 index 0000000..1ae41da --- /dev/null +++ b/tests/01.md.dump @@ -0,0 +1,8 @@ +# This is a test + +Hello world + +---------- +# This is a second slide + +lololol diff --git a/tests/02.lhs b/tests/02.lhs new file mode 100644 index 0000000..fd7a5d3 --- /dev/null +++ b/tests/02.lhs @@ -0,0 +1,6 @@ +This is how you define a `String` in Haskell: + +> test :: String +> test = "Hello World!" + +Cool, right? diff --git a/tests/02.lhs.dump b/tests/02.lhs.dump new file mode 100644 index 0000000..d9e7171 --- /dev/null +++ b/tests/02.lhs.dump @@ -0,0 +1,8 @@ +This is how you define a  String  in Haskell: + +   +  test :: String  +  test = "Hello World!"  +   + +Cool, right? diff --git a/tests/03.md b/tests/03.md new file mode 100644 index 0000000..6b3ae16 --- /dev/null +++ b/tests/03.md @@ -0,0 +1,46 @@ +Inline markups: + +- ~~striked out~~ +- + +--- + +> Some quote + +> Quote with embedded list: +> +> - Hello +> - World + +--- + +- List with an embedded quote: + + > Tu quoque + + Wow rad stuff. + +- Second item in that list. + +--- + +Code with empty line: + + puts "wow" + + puts "amaze" + +--- + +Code in ordered list: + +1. Do you know the coolest codes? + + It's this: + + fire_missiles() + cancel() + + Great + +2. Also `fib` is pretty cool yeah diff --git a/tests/03.md.dump b/tests/03.md.dump new file mode 100644 index 0000000..e8b6b69 --- /dev/null +++ b/tests/03.md.dump @@ -0,0 +1,48 @@ +Inline markups: + + - ~~striked out~~ + - <http://example.com> + +---------- +> Some quote + +> Quote with embedded list: +>  +>  - Hello +>  - World + +---------- + - List with an embedded quote: + + > Tu quoque + + Wow rad stuff. + + - Second item in that list. + + +---------- +Code with empty line: + +   +  puts "wow"  +   +  puts "amaze"  +   + +---------- +Code in ordered list: + +1. Do you know the coolest codes? + + It's this: + +   +  fire_missiles()  +  cancel()  +   + + Great + +2. Also  fib  is pretty cool yeah + diff --git a/tests/bolditalic.md b/tests/bolditalic.md new file mode 100644 index 0000000..f680dc1 --- /dev/null +++ b/tests/bolditalic.md @@ -0,0 +1,8 @@ +--- +patat: + theme: + emph: [italic] + strong: [bold] +... + +**Strong** and _emph_. diff --git a/tests/bolditalic.md.dump b/tests/bolditalic.md.dump new file mode 100644 index 0000000..0a17414 --- /dev/null +++ b/tests/bolditalic.md.dump @@ -0,0 +1 @@ +Strong and emph. diff --git a/tests/comments.md b/tests/comments.md new file mode 100644 index 0000000..36ab949 --- /dev/null +++ b/tests/comments.md @@ -0,0 +1,16 @@ +# This is a test + +Hello world + + + +# This is a second slide + + + +Where are my raw blocks at + + diff --git a/tests/comments.md.dump b/tests/comments.md.dump new file mode 100644 index 0000000..296a5ac --- /dev/null +++ b/tests/comments.md.dump @@ -0,0 +1,8 @@ +# This is a test + +Hello world + +---------- +# This is a second slide + +Where are my raw blocks at diff --git a/tests/deflist.md b/tests/deflist.md new file mode 100644 index 0000000..81aee19 --- /dev/null +++ b/tests/deflist.md @@ -0,0 +1,20 @@ +Term 1 + +: Definition 1 + +Term 2 with *inline markup* + +: Definition 2 + + { some code, part of Definition 2 } + + Third paragraph of definition 2. + +--- + +Term 1 + ~ Definition 1 + +Term 2 + ~ Definition 2a + ~ Definition 2b diff --git a/tests/deflist.md.dump b/tests/deflist.md.dump new file mode 100644 index 0000000..8089fda --- /dev/null +++ b/tests/deflist.md.dump @@ -0,0 +1,24 @@ +Term 1 + +: Definition 1 + +Term 2 with inline markup + +: Definition 2 + +   +  { some code, part of Definition 2 }  +   + + Third paragraph of definition 2. + +---------- +Term 1 + +: Definition 1 + +Term 2 + +: Definition 2a + +: Definition 2b diff --git a/tests/extentions0.md b/tests/extentions0.md new file mode 100644 index 0000000..a001311 --- /dev/null +++ b/tests/extentions0.md @@ -0,0 +1,9 @@ +--- +patat: + pandocExtensions: + - patat_extensions + - autolink_bare_uris + - emoji +... + +Check out this example: http://example.com/ :smile: diff --git a/tests/extentions0.md.dump b/tests/extentions0.md.dump new file mode 100644 index 0000000..9e8b1a6 --- /dev/null +++ b/tests/extentions0.md.dump @@ -0,0 +1 @@ +Check out this example: <http://example.com/> 😄 diff --git a/tests/extentions1.md b/tests/extentions1.md new file mode 100644 index 0000000..62c770b --- /dev/null +++ b/tests/extentions1.md @@ -0,0 +1,7 @@ +--- +patat: + pandocExtensions: + - emoji +... + +The patat default ~~strikeout~~ is not enabled, but emojis are :smile: diff --git a/tests/extentions1.md.dump b/tests/extentions1.md.dump new file mode 100644 index 0000000..26b7986 --- /dev/null +++ b/tests/extentions1.md.dump @@ -0,0 +1 @@ +The patat default ~~strikeout~~ is not enabled, but emojis are 😄 diff --git a/tests/fragments.md b/tests/fragments.md new file mode 100644 index 0000000..510baa2 --- /dev/null +++ b/tests/fragments.md @@ -0,0 +1,27 @@ +--- +patat: + incrementalLists: true +... + +- This list +- is displayed + + * item + * by item + +- Or sometimes + + > * all at + > * once + +--- + +Legen + +. . . + +wait for it + +. . . + +Dary! diff --git a/tests/fragments.md.dump b/tests/fragments.md.dump new file mode 100644 index 0000000..c29b455 --- /dev/null +++ b/tests/fragments.md.dump @@ -0,0 +1,54 @@ + + +~~~frag + - This list + +~~~frag + - This list + - is displayed + + + + +~~~frag + - This list + - is displayed + +  * item + + +~~~frag + - This list + - is displayed + +  * item +  * by item + + +~~~frag + - This list + - is displayed + +  * item +  * by item + + - Or sometimes + +  * all at +  * once + + +---------- +Legen + +~~~frag +Legen + +wait for it + +~~~frag +Legen + +wait for it + +Dary! diff --git a/tests/headers.md b/tests/headers.md new file mode 100644 index 0000000..73d9ea5 --- /dev/null +++ b/tests/headers.md @@ -0,0 +1,15 @@ +# This could be a title + +## This is nested + +Here is some content + +## This is also nested + +Here is more content + +# Another topic + +## What is going on? + +I think we can display slides? diff --git a/tests/headers.md.dump b/tests/headers.md.dump new file mode 100644 index 0000000..2b52c98 --- /dev/null +++ b/tests/headers.md.dump @@ -0,0 +1,21 @@ +~~~title +# This could be a title + +---------- +## This is nested + +Here is some content + +---------- +## This is also nested + +Here is more content + +---------- +~~~title +# Another topic + +---------- +## What is going on? + +I think we can display slides? diff --git a/tests/links.md b/tests/links.md new file mode 100644 index 0000000..153f959 --- /dev/null +++ b/tests/links.md @@ -0,0 +1,8 @@ +This is an "automatic link": . + +This is an [inline link](/url), and here's [one with +a title](http://fsf.org "click here for a good time!"). + +Let's talk about [foo][foosite] + +[foosite]: http://foo.com/ diff --git a/tests/links.md.dump b/tests/links.md.dump new file mode 100644 index 0000000..2862e9a --- /dev/null +++ b/tests/links.md.dump @@ -0,0 +1,10 @@ +This is an "automatic link": <https://jaspervdj.be>. + +This is an [inline link], and here's [one with +a title]. + +Let's talk about [foo] + +[inline link](/url) +[one with a title](http://fsf.org "click here for a good time!") +[foo](http://foo.com/) \ No newline at end of file diff --git a/tests/lists.md b/tests/lists.md new file mode 100644 index 0000000..d534704 --- /dev/null +++ b/tests/lists.md @@ -0,0 +1,13 @@ +- This is a nested list. + + * The nested items should have different list markers. + + * I mean, they can be the same, but it doesn't look nice. + + printf("Nested code block!\n") + + * Cool right? + + Definitely super cool + +- One final item diff --git a/tests/lists.md.dump b/tests/lists.md.dump new file mode 100644 index 0000000..1305289 --- /dev/null +++ b/tests/lists.md.dump @@ -0,0 +1,15 @@ + - This is a nested list. + +  * The nested items should have different list markers. + +  * I mean, they can be the same, but it doesn't look nice. + + printf("Nested code block!\n") + +  * Cool right? + + Definitely super cool + + + - One final item + diff --git a/tests/margins.md b/tests/margins.md new file mode 100644 index 0000000..5d0a59c --- /dev/null +++ b/tests/margins.md @@ -0,0 +1,17 @@ +--- +patat: + wrap: true + columns: 57 # 10 + 42 + 5 + margins: + left: 10 + right: 5 +... + +This text will have 10 spaces on the left. + +- So + * will + * these + * bullets + +This line will have 10 spaces on the left, but will also break after "left". diff --git a/tests/margins.md.dump b/tests/margins.md.dump new file mode 100644 index 0000000..5c3117b --- /dev/null +++ b/tests/margins.md.dump @@ -0,0 +1,10 @@ + This text will have 10 spaces on the left. +  +  - So +  * will +  * these +  * bullets + +  + This line will have 10 spaces on the left, + but will also break after "left". diff --git a/tests/meta.md b/tests/meta.md new file mode 100644 index 0000000..2ba5db9 --- /dev/null +++ b/tests/meta.md @@ -0,0 +1,12 @@ +--- +patat: + theme: + bulletListMarkers: '<>' +... + +- Hello +- World + * How + * Are + * You + * Doing diff --git a/tests/meta.md.dump b/tests/meta.md.dump new file mode 100644 index 0000000..740ed6b --- /dev/null +++ b/tests/meta.md.dump @@ -0,0 +1,7 @@ + < Hello + < World +  > How +  > Are +  > You +  > Doing + diff --git a/tests/slidelevel0.md b/tests/slidelevel0.md new file mode 100644 index 0000000..b07adab --- /dev/null +++ b/tests/slidelevel0.md @@ -0,0 +1,12 @@ +--- +patat: + slideLevel: 0 +--- + +# We should not split slides + +Never + +# At all + +Because we have `slideLevel` set to 0 diff --git a/tests/slidelevel0.md.dump b/tests/slidelevel0.md.dump new file mode 100644 index 0000000..c31c2e0 --- /dev/null +++ b/tests/slidelevel0.md.dump @@ -0,0 +1,7 @@ +# We should not split slides + +Never + +# At all + +Because we have  slideLevel  set to 0 diff --git a/tests/slidelevel1.md b/tests/slidelevel1.md new file mode 100644 index 0000000..dc531c4 --- /dev/null +++ b/tests/slidelevel1.md @@ -0,0 +1,26 @@ +--- +patat: + slideLevel: 1 +--- + +# This starts a new slide + +## But this does not + +Here is some content + +## And another header + +And more content (yep) + +# This should start a new slide + +## With some content + +### Very deeply nested + +#### Is a hidden message + +##### A dark secret... + +jet fuel can't melt steel beams diff --git a/tests/slidelevel1.md.dump b/tests/slidelevel1.md.dump new file mode 100644 index 0000000..3aa8af5 --- /dev/null +++ b/tests/slidelevel1.md.dump @@ -0,0 +1,22 @@ +# This starts a new slide + +## But this does not + +Here is some content + +## And another header + +And more content (yep) + +---------- +# This should start a new slide + +## With some content + +### Very deeply nested + +#### Is a hidden message + +##### A dark secret... + +jet fuel can't melt steel beams diff --git a/tests/slidelevel2.md b/tests/slidelevel2.md new file mode 100644 index 0000000..25e8795 --- /dev/null +++ b/tests/slidelevel2.md @@ -0,0 +1,15 @@ +# This is a title + +## This is a slide + +Here is some content + +## And another slide + +And more content (yep) + +# This is another title + +## With some content + +Yay diff --git a/tests/slidelevel2.md.dump b/tests/slidelevel2.md.dump new file mode 100644 index 0000000..1a400f2 --- /dev/null +++ b/tests/slidelevel2.md.dump @@ -0,0 +1,21 @@ +~~~title +# This is a title + +---------- +## This is a slide + +Here is some content + +---------- +## And another slide + +And more content (yep) + +---------- +~~~title +# This is another title + +---------- +## With some content + +Yay diff --git a/tests/syntax.md b/tests/syntax.md new file mode 100644 index 0000000..f6c803d --- /dev/null +++ b/tests/syntax.md @@ -0,0 +1,14 @@ +--- +patat: + theme: + syntaxHighlighting: + decVal: [bold, onDullRed] +... + +Some simple code: + +```c +int main(int argc, char **argv) { + return 0; +} +``` diff --git a/tests/syntax.md.dump b/tests/syntax.md.dump new file mode 100644 index 0000000..eb4893f --- /dev/null +++ b/tests/syntax.md.dump @@ -0,0 +1,7 @@ +Some simple code: + +   +  int main(int argc, char **argv) {  +  return 0;  +  }  +   diff --git a/tests/tables.md b/tests/tables.md new file mode 100644 index 0000000..fe7d72e --- /dev/null +++ b/tests/tables.md @@ -0,0 +1,48 @@ +# Normal simple table + + Right Left Center Default +------- ------ ---------- ------- + 12 12 12 12 + 123 123 123 123 + 1 1 1 1 + +Table: Demonstration of simple table syntax. + + +# Headerless table + +------- ------ ---------- ------- + 12 12 12 12 + 123 123 123 123 + 1 1 1 1 +------- ------ ---------- ------- + +# Multiline + +------------------------------------------------------------- + Centered Default Right Left + Header Aligned Aligned Aligned +----------- ------- --------------- ------------------------- + First row 12.0 Example of a row that + spans multiple lines. + + Second row 5.0 Here's another one. Note + the blank line between + rows. +------------------------------------------------------------- + +Table: Here's the caption. It, too, may span +multiple lines. + +# Headerless multiline + +----------- ------- --------------- ------------------------- + First row 12.0 Example of a row that + spans multiple lines. + + Second row 5.0 Here's another one. Note + the blank line between + rows. +----------- ------- --------------- ------------------------- + +: Here's a multiline table without headers. diff --git a/tests/tables.md.dump b/tests/tables.md.dump new file mode 100644 index 0000000..0b0a93f --- /dev/null +++ b/tests/tables.md.dump @@ -0,0 +1,48 @@ +# Normal simple table + + Right Left Center Default + ----- ---- ------ ------- + 12 12 12 12  + 123 123 123 123  + 1 1 1 1  + + Table: Demonstration of simple table syntax. + +---------- +# Headerless table + + --- --- --- --- + 12 12 12 12 + 123 123 123 123 + 1 1 1 1  + --- --- --- --- + +---------- +# Multiline + + Centered Default Right Left  + Header Aligned Aligned Aligned  + -------- ------- ------- ------------------------ + First row 12.0 Example of a row that  + spans multiple lines.  +  + Second row 5.0 Here's another one. Note + the blank line between  + rows.  + + Table: Here's the caption. It, too, may span + multiple lines. + +---------- +# Headerless multiline + + ------ --- ---- ------------------------ + First row 12.0 Example of a row that  + spans multiple lines.  +  + Second row 5.0 Here's another one. Note + the blank line between  + rows.  + ------ --- ---- ------------------------ + + Table: Here's a multiline table without headers. diff --git a/tests/themes.md b/tests/themes.md new file mode 100644 index 0000000..ca2958c --- /dev/null +++ b/tests/themes.md @@ -0,0 +1,12 @@ +--- +patat: + theme: + bulletListMarkers: '-+' + emph: [onVividRed, underline] + strong: [rgb#f08000, onRgb#101060] +... + +- This is a simple list. + * With _nested_ items. + * One or two **bold**. +- The list theming is customized a bit. diff --git a/tests/themes.md.dump b/tests/themes.md.dump new file mode 100644 index 0000000..f68c671 --- /dev/null +++ b/tests/themes.md.dump @@ -0,0 +1,5 @@ + - This is a simple list. +  + With nested items. +  + One or two bold. + + - The list theming is customized a bit. diff --git a/tests/wrapping.md b/tests/wrapping.md new file mode 100644 index 0000000..bcffc16 --- /dev/null +++ b/tests/wrapping.md @@ -0,0 +1,25 @@ +--- +patat: + wrap: true + columns: 40 +... + +This is a long +sentence over multiple +lines which can be +re-wrapped. + + +This is a super long sentence over a single line which should also be re-wrapped. + + + This is a table and tables should not be wrapped + ------- ------- ---------- ---------- ---------- + 1 2 3 4 5 + 6 7 8 9 10 + +- This is a list +- This list has a really long sentence in it which should also be wrapped with proper indentation +- Another item + +This line is long, and then ends with `code` diff --git a/tests/wrapping.md.dump b/tests/wrapping.md.dump new file mode 100644 index 0000000..d44e767 --- /dev/null +++ b/tests/wrapping.md.dump @@ -0,0 +1,20 @@ +This is a long sentence over multiple +lines which can be re-wrapped. + +This is a super long sentence over a +single line which should also be +re-wrapped. + + This is a table and tables should not be wrapped + ------- ------- ---------- ---------- ---------- + 1 2 3 4 5  + 6 7 8 9 10  + + - This is a list + - This list has a really long sentence + in it which should also be wrapped + with proper indentation + - Another item + +This line is long, and then ends with + code